diff --git a/CHANGELOG.md b/CHANGELOG.md index 699b88bc72..8493e45548 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -23,11 +23,17 @@ #### :boom: Breaking Change - Parse `assert` as a regular function. `assert` is no longer a unary expression. Example: before `assert 1 == 2` is parsed as `(assert 1) == 2`, now it is parsed as `assert(1 == 2)`. https://github.com/rescript-lang/rescript-compiler/pull/6180 +- `-bs-super-errors` flag has been removed along with Super_errors. https://github.com/rescript-lang/rescript-compiler/pull/6199 #### :bug: Bug Fix - Make "rescript format" work with node 10 again and set minimum required node version to 10 in package.json. https://github.com/rescript-lang/rescript-compiler/pull/6186 +#### :nail_care: Polish + +- Add location information to duplicate type definition error messages. https://github.com/rescript-lang/rescript-compiler/pull/6199 +- Replace normal module errors with Super_error module, and clean up Super_error. https://github.com/rescript-lang/rescript-compiler/pull/6199 + # 11.0.0-alpha.4 #### :rocket: Main New Feature diff --git a/jscomp/bsc/dune b/jscomp/bsc/dune index 4ef6769f89..48da8f9df9 100644 --- a/jscomp/bsc/dune +++ b/jscomp/bsc/dune @@ -8,5 +8,4 @@ (public_name bsc) (flags (:standard -w +a-4-9-30-40-41-42-48-70)) - (libraries common core depends gentype js_parser syntax super_errors - outcome_printer)) + (libraries common core depends gentype js_parser syntax outcome_printer)) diff --git a/jscomp/bsc/rescript_compiler_main.ml b/jscomp/bsc/rescript_compiler_main.ml index 4df293ca7a..b3581e1f82 100644 --- a/jscomp/bsc/rescript_compiler_main.ml +++ b/jscomp/bsc/rescript_compiler_main.ml @@ -25,8 +25,7 @@ let setup_compiler_printer (syntax_kind : [ syntax_kind | `default])= | `default -> () | #syntax_kind as k -> Config.syntax_kind := k); let syntax_kind = !Config.syntax_kind in - if syntax_kind = `rescript then begin - Lazy.force Super_main.setup; + if syntax_kind = `rescript then begin Lazy.force Res_outcome_printer.setup end @@ -206,7 +205,6 @@ let print_version_string () = let [@inline] set s : Bsc_args.spec = Unit (Unit_set s) let [@inline] clear s : Bsc_args.spec = Unit (Unit_clear s) -let [@inline] unit_lazy s : Bsc_args.spec = Unit(Unit_lazy s) let [@inline] string_call s : Bsc_args.spec = String (String_call s) let [@inline] string_optional_set s : Bsc_args.spec = @@ -294,10 +292,6 @@ let buckle_script_flags : (string * Bsc_args.spec * string) array = (******************************************************************************) - - "-bs-super-errors", unit_lazy Super_main.setup, - "*internal* Better error message combined with other tools "; - "-unboxed-types", set Clflags.unboxed_types, "*internal* Unannotated unboxable types will be unboxed"; 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 new file mode 100644 index 0000000000..c62825d7f3 --- /dev/null +++ b/jscomp/build_tests/super_errors/expected/repeated_def_extension_constr.res.expected @@ -0,0 +1,12 @@ + + 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 new file mode 100644 index 0000000000..4fe5ea96c7 --- /dev/null +++ b/jscomp/build_tests/super_errors/expected/repeated_def_module_types.res.expected @@ -0,0 +1,12 @@ + + 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 new file mode 100644 index 0000000000..a381a9bf13 --- /dev/null +++ b/jscomp/build_tests/super_errors/expected/repeated_def_modules.res.expected @@ -0,0 +1,12 @@ + + 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 new file mode 100644 index 0000000000..5c06f370be --- /dev/null +++ b/jscomp/build_tests/super_errors/expected/repeated_def_types.res.expected @@ -0,0 +1,12 @@ + + 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/type2.res.expected b/jscomp/build_tests/super_errors/expected/type2.res.expected new file mode 100644 index 0000000000..3e0bba689f --- /dev/null +++ b/jscomp/build_tests/super_errors/expected/type2.res.expected @@ -0,0 +1,14 @@ + + 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 + Somewhere wanted: 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 new file mode 100644 index 0000000000..57215c99cc --- /dev/null +++ b/jscomp/build_tests/super_errors/expected/type3.res.expected @@ -0,0 +1,13 @@ + + 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/fixtures/repeated_def_extension_constr.res b/jscomp/build_tests/super_errors/fixtures/repeated_def_extension_constr.res new file mode 100644 index 0000000000..80f0641497 --- /dev/null +++ b/jscomp/build_tests/super_errors/fixtures/repeated_def_extension_constr.res @@ -0,0 +1,3 @@ +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 new file mode 100644 index 0000000000..e6a579643b --- /dev/null +++ b/jscomp/build_tests/super_errors/fixtures/repeated_def_module_types.res @@ -0,0 +1,3 @@ +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 new file mode 100644 index 0000000000..9d9253c634 --- /dev/null +++ b/jscomp/build_tests/super_errors/fixtures/repeated_def_modules.res @@ -0,0 +1,3 @@ +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 new file mode 100644 index 0000000000..995e8183f0 --- /dev/null +++ b/jscomp/build_tests/super_errors/fixtures/repeated_def_types.res @@ -0,0 +1,3 @@ +type a + +type a diff --git a/jscomp/build_tests/super_errors/fixtures/type2.res b/jscomp/build_tests/super_errors/fixtures/type2.res new file mode 100644 index 0000000000..12f507ad57 --- /dev/null +++ b/jscomp/build_tests/super_errors/fixtures/type2.res @@ -0,0 +1,7 @@ +@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 new file mode 100644 index 0000000000..8a672bd087 --- /dev/null +++ b/jscomp/build_tests/super_errors/fixtures/type3.res @@ -0,0 +1 @@ +let u = [] diff --git a/jscomp/build_tests/super_errors/input.js b/jscomp/build_tests/super_errors/input.js index 0604181980..e835e4d4bc 100644 --- a/jscomp/build_tests/super_errors/input.js +++ b/jscomp/build_tests/super_errors/input.js @@ -27,7 +27,7 @@ let atLeastOneTaskFailed = false fixtures.forEach(fileName => { const fullFilePath = path.join(__dirname, 'fixtures', fileName) - const command = `${prefix} -color always -bs-super-errors ${fullFilePath}` + const command = `${prefix} -color always ${fullFilePath}` console.log(`running ${command}`) child_process.exec(command, (err, stdout, stderr) => { doneTasksCount++ diff --git a/jscomp/gentype_tests/typescript-react-example/bsconfig.json b/jscomp/gentype_tests/typescript-react-example/bsconfig.json index b303724d71..99dd46c6f2 100644 --- a/jscomp/gentype_tests/typescript-react-example/bsconfig.json +++ b/jscomp/gentype_tests/typescript-react-example/bsconfig.json @@ -15,7 +15,7 @@ "exportInterfaces": false }, "name": "sample-typescript-app", - "bsc-flags": ["-bs-super-errors"], + "bsc-flags": [], "jsx": { "version": 3 }, "bs-dependencies": ["@rescript/react"], "sources": [ diff --git a/jscomp/super_errors/super_code_frame.ml b/jscomp/ml/code_frame.ml similarity index 100% rename from jscomp/super_errors/super_code_frame.ml rename to jscomp/ml/code_frame.ml diff --git a/jscomp/ml/env.ml b/jscomp/ml/env.ml index 99119bc1a8..8a914c825a 100644 --- a/jscomp/ml/env.ml +++ b/jscomp/ml/env.ml @@ -2276,32 +2276,42 @@ let env_of_only_summary env_from_summary env = 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(modname, ps_name, filename) -> fprintf ppf - "Wrong file naming: %a@ contains the compiled interface for @ \ - %s when %s was expected" - Location.print_filename filename ps_name modname - | Inconsistent_import(name, source1, source2) -> fprintf ppf + | 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@]" + 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" + 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" + 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 + fprintf ppf "'%s' is not a valid value identifier." + name let () = Location.register_error_of_exn diff --git a/jscomp/ml/lexer.mll b/jscomp/ml/lexer.mll index 279c207058..3663fd3d33 100644 --- a/jscomp/ml/lexer.mll +++ b/jscomp/ml/lexer.mll @@ -254,7 +254,7 @@ let report_error ppf = function | Unterminated_string_in_comment (_, loc) -> fprintf ppf "This comment contains an unterminated string literal@.\ %aString literal begins here" - Location.print_error loc + (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 -> diff --git a/jscomp/ml/location.ml b/jscomp/ml/location.ml index 416cc23d2b..07c76ecc95 100644 --- a/jscomp/ml/location.ml +++ b/jscomp/ml/location.ml @@ -104,40 +104,114 @@ let print_filename ppf file = let reset () = num_loc_lines := 0 -let (msg_file, msg_line, msg_chars, msg_to, msg_colon) = - ("File \"", "\", line ", ", characters ", "-", ":") - (* 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 - -let print_loc ppf loc = + 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 (file, line, startchar) = get_pos_info loc.loc_start in - let startchar = startchar + 1 in - let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in - begin - fprintf ppf "%s@{%a%s%i" msg_file print_filename file msg_line line; - if startchar >= 0 then - fprintf ppf "%s%i%s%i" msg_chars startchar msg_to endchar; - fprintf ppf "@}" - end + 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 default_printer ppf loc = - setup_colors (); - fprintf ppf "@{%a@}%s@," print_loc loc msg_colon +let print ~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 + let src = 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 printer = ref default_printer -let print ppf loc = !printer ppf loc - let error_prefix = "Error" -let warning_prefix = "Warning" let print_error_prefix ppf = setup_colors (); @@ -153,30 +227,22 @@ let print_compact ppf loc = end ;; -let print_error ppf loc = - fprintf ppf "%a%t:" print loc print_error_prefix; +let print_error intro ppf loc = + fprintf ppf "%a%t:" (print ~message_kind:`error intro) loc print_error_prefix; ;; -let print_error_cur_file ppf () = print_error ppf (in_file !input_name);; - let default_warning_printer loc ppf w = match Warnings.report w with | `Inactive -> () - | `Active { Warnings. number; message; is_error; sub_locs } -> + | `Active { Warnings. number = _; message = _; is_error; sub_locs = _} -> setup_colors (); - fprintf ppf "@["; - print ppf loc; - if is_error - then - fprintf ppf "%t (%s %d): %s@," print_error_prefix - (String.uncapitalize_ascii warning_prefix) number message - else fprintf ppf "@{%s@} %d: %s@," warning_prefix number message; - List.iter - (fun (loc, msg) -> - if loc <> none then fprintf ppf " %a %s@," print loc msg - ) - sub_locs; - fprintf ppf "@]" + 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 ;; @@ -225,10 +291,13 @@ let pp_ksprintf ?before k fmt = 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 = - Format.pp_print_as ppf (String.length error_prefix + 2 (* ": " *)) "" + (* 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 @@ -258,11 +327,14 @@ let error_of_exn exn = 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 ppf ({loc; msg; sub}) = - fprintf ppf "@[%a %s" print_error loc msg; - List.iter (Format.fprintf ppf "@,@[<2>%a@]" default_error_reporter) sub; - fprintf ppf "@]" + setup_colors (); + (* open a vertical box. Everything in our message is indented 2 spaces *) + Format.fprintf ppf "@[@, %a@, %s@,@]" (print ~message_kind:`error "We've found a bug for you!") loc msg; + List.iter (Format.fprintf ppf "@,@[%a@]" default_error_reporter) sub +(* no need to flush here; location's report_exception (which uses this ultimately) flushes *) let error_reporter = ref default_error_reporter diff --git a/jscomp/ml/location.mli b/jscomp/ml/location.mli index 73b7daacd7..5c24188ca4 100644 --- a/jscomp/ml/location.mli +++ b/jscomp/ml/location.mli @@ -56,16 +56,12 @@ 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: formatter -> t -> unit -val print_error_cur_file: formatter -> unit -> 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 default_printer : formatter -> t -> unit -val printer : (formatter -> t -> unit) ref - val warning_printer : (t -> formatter -> Warnings.t -> unit) ref (** Hook for intercepting warnings. *) @@ -82,7 +78,7 @@ type 'a loc = { val mknoloc : 'a -> 'a loc val mkloc : 'a -> t -> 'a loc -val print: formatter -> t -> unit +val print: message_kind:[< `error | `warning | `warning_as_error > `warning] -> string -> formatter -> t -> unit val print_compact: formatter -> t -> unit val print_filename: formatter -> string -> unit diff --git a/jscomp/ml/typecore.ml b/jscomp/ml/typecore.ml index e9aea7c5ff..a2e145e417 100644 --- a/jscomp/ml/typecore.ml +++ b/jscomp/ml/typecore.ml @@ -610,6 +610,119 @@ let rec 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 + | _ -> None + +let print_expr_type_clash 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 -> + fprintf ppf "This has type:") + (function ppf -> + fprintf ppf "Somewhere wanted:"); + 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" @@ -3656,36 +3769,55 @@ let report_error env ppf = function fprintf ppf "@[The record field %a is polymorphic.@ %s@]" longident lid "You cannot instantiate it in a pattern." | Constructor_arity_mismatch(lid, expected, provided) -> - fprintf ppf - "@[The constructor %a@ expects %i argument(s),@ \ - but is applied here to %i argument(s)@]" - longident 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) -> - 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") + (* 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 -> - 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") + (* 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) -> - 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") + (* 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,_),_,_)}) :: _ @@ -3693,24 +3825,30 @@ let report_error env ppf = function fprintf ppf "This method has %s but was expected %s" a b | Expr_type_clash trace -> - report_unification_error ppf env trace - (function ppf -> - fprintf ppf "This expression has type") - (function ppf -> - fprintf ppf "but an expression was expected of type") + (* modified *) + fprintf ppf "@["; + print_expr_type_clash env trace ppf; + fprintf ppf "@]" | Apply_non_function typ -> - reset_and_mark_loops typ; - begin match (repr typ).desc with - Tarrow _ -> - fprintf ppf "@[@[<2>This function has type@ %a@]" - type_expr typ; - fprintf ppf "@ @[It is applied to too many arguments;@ %s@]@]" - "maybe you forgot a `;'." + (* modified *) + reset_and_mark_loops typ; + 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 - "This is not a function; it cannot be applied." - end + 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" @@ -3732,20 +3870,22 @@ let report_error env ppf = function | Label_not_mutable lid -> fprintf ppf "The record field %a is not mutable" longident lid | Wrong_name (eorp, ty, kind, p, name, valid_names) -> - reset_and_mark_loops ty; - 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 - path p; - end else begin - fprintf ppf "@[@[<2>%s type@ %a@]@ " + (* modified *) + reset_and_mark_loops ty; + 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 "@[@[<2>%s type@ @{%a@}@]@ " eorp type_expr ty; - fprintf ppf "The %s %s does not belong to type %a@]" + + fprintf ppf "The %s @{%s@} does not belong to type @{%a@}@]" (label_of_kind kind) - name (*kind*) path p; - end; - spellcheck ppf name valid_names; + name (*kind*) Printtyp.path p; + 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 @@ -3770,29 +3910,35 @@ let report_error env ppf = function | Not_subtype(tr1, tr2) -> report_subtyping_error ppf env tr1 "is not a subtype of" tr2 | Coercion_failure (ty, ty', trace, b) -> - report_unification_error ppf env trace - (function ppf -> - let ty, ty' = prepare_expansion (ty, ty') in - fprintf ppf - "This expression cannot be coerced to type@;<1 2>%a;@ it has type" - (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." + (* 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) -> - reset_and_mark_loops ty; - 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 - fprintf ppf "This expression should not be a function,@ "; - fprintf ppf "the expected type is@ %a" + (* modified *) + reset_and_mark_loops ty; + 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 + end | Abstract_wrong_label (l, ty) -> let label_mark = function | Nolabel -> "but its first argument is not labelled" @@ -3819,9 +3965,10 @@ let report_error env ppf = function 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) -> - report_unification_error ppf env trace - (fun ppf -> fprintf ppf "This %s has type" kind) - (fun ppf -> fprintf ppf "which is less general than") + (* 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 -> @@ -3832,11 +3979,12 @@ let report_error env ppf = function "This expression is packed module, but the expected type is@ %a" type_expr ty | Recursive_local_constraint trace -> - report_unification_error ppf env trace - (function ppf -> - fprintf ppf "Recursive local constraint when unifying") - (function ppf -> - fprintf ppf "with") + (* 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" diff --git a/jscomp/ml/typemod.ml b/jscomp/ml/typemod.ml index 8972d987a9..76b9cf1e5a 100644 --- a/jscomp/ml/typemod.ml +++ b/jscomp/ml/typemod.ml @@ -33,7 +33,7 @@ type error = 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 + | Repeated_name of string * string * Warnings.loc | Non_generalizable of type_expr | Non_generalizable_module of module_type | Interface_not_compiled of string @@ -623,25 +623,26 @@ let check_recmod_typedecls env sdecls decls = module StringSet = Set.Make(struct type t = string let compare (x:t) y = String.compare x y end) -let check cl loc set_ref name = - if StringSet.mem name !set_ref - then raise(Error(loc, Env.empty, Repeated_name(cl, name))) - else set_ref := StringSet.add name !set_ref +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: StringSet.t ref; - modules: StringSet.t ref; - modtypes: StringSet.t ref; - typexts: StringSet.t ref; + 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 = ref StringSet.empty; - modules = ref StringSet.empty; - modtypes = ref StringSet.empty; - typexts = ref StringSet.empty; + types = (Hashtbl.create 10); + modules = (Hashtbl.create 10); + modtypes = (Hashtbl.create 10); + typexts = (Hashtbl.create 10); } @@ -1807,6 +1808,13 @@ let save_signature modname tsg outputprefix source_file initial_env cmi = 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 @@ -1853,18 +1861,31 @@ let report_error ppf = function "@[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_name(kind, name, repeated_loc) -> fprintf ppf - "@[Multiple definition of the %s name %s.@ \ - Names must be unique in a given structure or signature.@]" kind name + "@[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 -> - fprintf ppf - "@[The type of this expression,@ %a,@ \ - contains type variables that cannot be generalized@]" type_scheme 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 -> - fprintf ppf - "@[The type of this module,@ %a,@ \ - contains type variables that cannot be generalized@]" modtype 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.@]" diff --git a/jscomp/ml/typemod.mli b/jscomp/ml/typemod.mli index f8cd85f89e..e7bcecec5f 100644 --- a/jscomp/ml/typemod.mli +++ b/jscomp/ml/typemod.mli @@ -65,7 +65,7 @@ type error = 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 + | Repeated_name of string * string * Warnings.loc | Non_generalizable of type_expr | Non_generalizable_module of module_type | Interface_not_compiled of string diff --git a/jscomp/ml/typetexp.ml b/jscomp/ml/typetexp.ml index b288e6016c..8074e6b7b3 100644 --- a/jscomp/ml/typetexp.ml +++ b/jscomp/ml/typetexp.ml @@ -827,6 +827,32 @@ let transl_type_scheme env styp = 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 @@ -834,16 +860,13 @@ let spellcheck ppf fold env lid = match lid with | Longident.Lapply _ -> () | Longident.Lident s -> - Misc.did_you_mean ppf (fun () -> choices ~path:None 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) + 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_values = fold_simple Env.fold_values -let fold_types = fold_simple Env.fold_types -let fold_modules = fold_simple Env.fold_modules 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 @@ -857,8 +880,11 @@ let report_error env ppf = function should be handled *) fprintf ppf "Unbound type parameter %s@." name | Unbound_type_constructor lid -> - fprintf ppf "Unbound type constructor %a" longident lid; - spellcheck ppf fold_types env 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 @@ -939,17 +965,69 @@ let report_error env ppf = function fprintf ppf "@[Method '%s' has type %a,@ which should be %a@]" l Printtyp.type_expr ty Printtyp.type_expr ty') | Unbound_value lid -> - fprintf ppf "Unbound value %a" longident lid; - spellcheck ppf fold_values env 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 -> - fprintf ppf "Unbound module %a" longident lid; - spellcheck ppf fold_modules env 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 list it in bsconfig.json?@,\ + - @[Did you run `rescript build` instead of `rescript build -with-deps`@ (latter builds third-parties)@]?\ + @]@,\ + - Did you include the file's directory in bsconfig.json?@]\ + @]" + Printtyp.longident lid + end + end; + super_spellcheck ppf Env.fold_modules env lid |> ignore | Unbound_constructor lid -> - fprintf ppf "Unbound constructor %a" longident lid; - spellcheck ppf fold_constructors env 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 -> - fprintf ppf "Unbound record field %a" longident lid; - spellcheck ppf fold_labels env 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; diff --git a/jscomp/ounit_tests/ounit_cmd_tests.ml b/jscomp/ounit_tests/ounit_cmd_tests.ml index 421b50e080..c141f16786 100644 --- a/jscomp/ounit_tests/ounit_cmd_tests.ml +++ b/jscomp/ounit_tests/ounit_cmd_tests.ml @@ -276,38 +276,5 @@ let rec y = A y;; OUnit.assert_bool __LOC__ (Ext_string.contain_substring should_err.stderr "contravariant") end; - __LOC__ >:: begin fun _ -> - let should_err = bsc_check_eval {| - let u = [||] - |} in - OUnit.assert_bool __LOC__ - (Ext_string.contain_substring should_err.stderr "cannot be generalized") - end; - __LOC__ >:: begin fun _ -> - let should_err = bsc_check_eval {| -external push : 'a array -> 'a -> unit = "push" [@@send] -let a = [||] -let () = - push a 3 |. ignore ; - push a "3" |. ignore - |} in - OUnit.assert_bool __LOC__ - (Ext_string.contain_substring should_err.stderr "has type string") - end - (* __LOC__ >:: begin fun _ -> *) - (* let should_infer = perform_bsc [| "-i"; "-bs-eval"|] {| *) - (* let f = fun [@bs] x -> let (a,b) = x in a + b *) - (* |} in *) - (* let infer_type = bsc_eval (Printf.sprintf {| *) - - (* let f : %s = fun [@bs] x -> let (a,b) = x in a + b *) - (* |} should_infer.stdout ) in *) - (* begin *) - (* Ounit_cmd_util.debug_output should_infer ; *) - (* Ounit_cmd_util.debug_output infer_type ; *) - (* OUnit.assert_bool __LOC__ *) - (* ((Ext_string.is_empty infer_type.stderr)) *) - (* end *) - (* end *) ] diff --git a/jscomp/super_errors/.ocamlformat b/jscomp/super_errors/.ocamlformat deleted file mode 100644 index 593b6a1ffc..0000000000 --- a/jscomp/super_errors/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -disable diff --git a/jscomp/super_errors/README.md b/jscomp/super_errors/README.md deleted file mode 100644 index 0c7f1480d2..0000000000 --- a/jscomp/super_errors/README.md +++ /dev/null @@ -1,34 +0,0 @@ -Hello! This is the subdirectory for the new, newcomer-friendly ReScript warning & error report system. Most of the logic are lifted from the compiler (https://github.com/rescript-lang/ocaml/tree/master). The convention here is to have a `super_foo` for each corresponding compiler's file `foo`. So, for example, `warnings.ml` becomes `super_warnings.ml`. The exception is `super_main`, the entry point. - -Feel free to submit new ones or tweak existing messages in these files! They also have more precise comments in them that tells you how they work. - -### Develop - -Please see [CONTRIBUTING.md](../../CONTRIBUTING.md) for the build & testing setup. - -#### SuperErrors-specific Tests Flow - -Note: currently you can't test things with external libraries (e.g. ReasonReact). - -The fixture tests are located in `jscomp/build_tests/super_errors/` and look like: -``` -{some code} -/* -{the normal ocaml error output} - -===== - -{the supererrors output} -*/ - -{some more code} -/* -etc -*/ -``` - -Files in `formattingTests` get printed with `-colors always` so we can test formatting. The other ones are printed with `-colors never` so that it's readable. - -To add a new test case, see `jscomp/build_tests/super_errors/README.md`. - -To test the changes on a dummy project, see "Test on a Dummy Project" in [CONTRIBUTING.md](../../CONTRIBUTING.md). diff --git a/jscomp/super_errors/dune b/jscomp/super_errors/dune deleted file mode 100644 index b12940f1e4..0000000000 --- a/jscomp/super_errors/dune +++ /dev/null @@ -1,6 +0,0 @@ -(library - (name super_errors) - (wrapped false) - (flags - (:standard -w +a-4-9-40-42-70)) - (libraries ml)) diff --git a/jscomp/super_errors/super_code_frame.mli b/jscomp/super_errors/super_code_frame.mli deleted file mode 100644 index 49f8b7d872..0000000000 --- a/jscomp/super_errors/super_code_frame.mli +++ /dev/null @@ -1,6 +0,0 @@ -val print: is_warning:bool -> src:string -> startPos:Lexing.position -> endPos:Lexing.position -> string - -val setup : Misc.Color.setting option -> unit -(* [setup opt] will enable or disable color handling for print - according to the value of color setting [opt]. - Only the first call to this function has an effect. *) diff --git a/jscomp/super_errors/super_env.ml b/jscomp/super_errors/super_env.ml deleted file mode 100644 index 1701c81798..0000000000 --- a/jscomp/super_errors/super_env.ml +++ /dev/null @@ -1,50 +0,0 @@ -let fprintf = Format.fprintf - -(* taken from https://github.com/rescript-lang/ocaml/blob/d4144647d1bf9bc7dc3aadc24c25a7efa3a67915/typing/env.ml#L1842 *) -(* modified branches are commented *) -let report_error ppf = function - | Env.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 - -(* This will be called in super_main. This is how you'd override the default error printer from the compiler & register new error_of_exn handlers *) -let setup () = - Location.register_error_of_exn - (function - | Env.Error (Missing_module (loc, _, _) - | Illegal_value_name (loc, _) - as err) when loc <> Location.none -> - Some (Super_location.error_of_printer loc report_error err) - | Env.Error err -> Some (Super_location.error_of_printer_file report_error err) - | _ -> None - ) diff --git a/jscomp/super_errors/super_location.ml b/jscomp/super_errors/super_location.ml deleted file mode 100644 index bd9a033263..0000000000 --- a/jscomp/super_errors/super_location.ml +++ /dev/null @@ -1,127 +0,0 @@ -let fprintf = Format.fprintf - -let setup_colors () = - Misc.Color.setup !Clflags.color; - Super_code_frame.setup !Clflags.color - -let print_filename = Location.print_filename - -let print_loc ~normalizedRange ppf (loc : Location.t) = - setup_colors (); - 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 normalizedRange -;; - -let print ~message_kind intro ppf (loc : Location.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) = Location.get_pos_info loc.loc_start in - let (_, end_line, end_char) = Location.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 ~normalizedRange) loc; - match normalizedRange with - | None -> () - | Some _ -> begin - try - let src = 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" - (Super_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 -;; - -(* 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 super_error_reporter ppf ({loc; msg; sub} : Location.error) = - setup_colors (); - (* open a vertical box. Everything in our message is indented 2 spaces *) - Format.fprintf ppf "@[@, %a@, %s@,@]" (print ~message_kind:`error "We've found a bug for you!") loc msg; - List.iter (Format.fprintf ppf "@,@[%a@]" super_error_reporter) sub -(* no need to flush here; location's report_exception (which uses this ultimately) flushes *) - - -(* extracted from https://github.com/rescript-lang/ocaml/blob/d4144647d1bf9bc7dc3aadc24c25a7efa3a67915/parsing/location.ml#L299 *) -(* This is the warning report entry point. We'll replace the default printer with this one *) -let super_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 *) -;; - -(* taken from https://github.com/rescript-lang/ocaml/blob/d4144647d1bf9bc7dc3aadc24c25a7efa3a67915/parsing/location.ml#L354 *) -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 = Location.none) ?(sub = []) ?(if_highlight = "") fmt = - Location.pp_ksprintf - ~before:print_phanton_error_prefix - (fun msg -> Location.{loc; msg; sub; if_highlight}) - fmt - -let error_of_printer loc print x = - errorf ~loc "%a@?" print x - -let error_of_printer_file print x = - error_of_printer (Location.in_file !Location.input_name) print x - -(* This will be called in super_main. This is how you override the default error and warning printers *) -let setup () = - Location.error_reporter := super_error_reporter; - Location.warning_printer := super_warning_printer; diff --git a/jscomp/super_errors/super_location.mli b/jscomp/super_errors/super_location.mli deleted file mode 100644 index cd61fec6c9..0000000000 --- a/jscomp/super_errors/super_location.mli +++ /dev/null @@ -1,20 +0,0 @@ - -(* Needed for the online playground experience *) -val super_warning_printer : - Warnings.loc -> - Format.formatter -> - Warnings.t -> unit - -val error_of_printer : - Location.t -> - (Format.formatter -> 'a -> unit) -> - 'a -> - Location.error - -val error_of_printer_file : - (Format.formatter -> 'a -> unit) -> - 'a -> - Location.error - - -val setup : unit -> unit diff --git a/jscomp/super_errors/super_main.ml b/jscomp/super_errors/super_main.ml deleted file mode 100644 index 6dec8b4058..0000000000 --- a/jscomp/super_errors/super_main.ml +++ /dev/null @@ -1,7 +0,0 @@ -(* the entry point. This is used by rescript_compiler_main.ml *) -let setup = - lazy (Super_location.setup (); - Super_typetexp.setup (); - Super_typemod.setup (); - Super_typecore.setup (); - Super_env.setup ()) diff --git a/jscomp/super_errors/super_typecore.ml b/jscomp/super_errors/super_typecore.ml deleted file mode 100644 index 0f99ca1f0e..0000000000 --- a/jscomp/super_errors/super_typecore.ml +++ /dev/null @@ -1,290 +0,0 @@ -(* open Misc - open Asttypes - open Parsetree - open Types - open Typedtree - open Btype *) -open Ctype - -let fprintf = Format.fprintf -let sprintf = Format.sprintf -let longident = Printtyp.longident -let super_report_unification_error = Printtyp.super_report_unification_error -let reset_and_mark_loops = Printtyp.reset_and_mark_loops -let type_expr = Printtyp.type_expr - -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 - -(* given type1 is foo => bar => baz(qux) and type 2 is bar => baz(qux), return Some(foo) *) -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 - | _ -> None - -let print_expr_type_clash 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@]" type_expr argtype - | Labelled label -> - fprintf ppf "@[(~%s: %a)@]" label type_expr argtype - | Optional label -> - fprintf ppf "@[(?%s: %a)@]" label 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; - - super_report_unification_error ppf env trace - (function ppf -> - fprintf ppf "This has type:") - (function ppf -> - fprintf ppf "Somewhere wanted:"); - 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 - -(* Pasted from typecore.ml. Needed for some cases in report_error below *) -(* Records *) -let label_of_kind kind = - if kind = "record" then "field" else "constructor" - -let spellcheck ppf unbound_name valid_names = - Misc.did_you_mean ppf (fun () -> - Misc.spellcheck valid_names unbound_name - ) -(* taken from https://github.com/rescript-lang/ocaml/blob/d4144647d1bf9bc7dc3aadc24c25a7efa3a67915/typing/typecore.ml#L3769 *) -(* modified branches are commented *) -let report_error env ppf = function - | Typecore.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") - | 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 -> - (* modified *) - fprintf ppf "@["; - print_expr_type_clash env trace ppf; - fprintf ppf "@]" - | Apply_non_function typ -> - (* modified *) - reset_and_mark_loops typ; - 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 - | 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 *) - reset_and_mark_loops ty; - 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 - | 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") - | 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") - | Wrong_name (eorp, ty, kind, p, name, valid_names) -> - (* modified *) - reset_and_mark_loops ty; - 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 "@[@[<2>%s type@ @{%a@}@]@ " - eorp type_expr ty; - - fprintf ppf "The %s @{%s@} does not belong to type @{%a@}@]" - (label_of_kind kind) - name (*kind*) Printtyp.path p; - end; - spellcheck ppf name valid_names; - | anythingElse -> - Typecore.super_report_error_no_wrap_printing_env env ppf anythingElse - -let report_error env ppf err = - Printtyp.wrap_printing_env env (fun () -> report_error env ppf err) - -(* This will be called in super_main. This is how you'd override the default error printer from the compiler & register new error_of_exn handlers *) -let setup () = - Location.register_error_of_exn - (function - | Typecore.Error (loc, env, err) -> - Some (Super_location.error_of_printer loc (report_error env) err) - | Typecore.Error_forward err -> - Some err - | _ -> - None - ) diff --git a/jscomp/super_errors/super_typemod.ml b/jscomp/super_errors/super_typemod.ml deleted file mode 100644 index 4c3546f010..0000000000 --- a/jscomp/super_errors/super_typemod.ml +++ /dev/null @@ -1,51 +0,0 @@ -open Printtyp - -let fprintf = Format.fprintf - -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 () - -(* taken from https://github.com/rescript-lang/ocaml/blob/d4144647d1bf9bc7dc3aadc24c25a7efa3a67915/typing/typemod.ml#L1754 *) -(* modified branches are commented *) -let report_error ppf = function - | Typemod.Non_generalizable typ -> - (* modified *) - fprintf ppf "@["; - non_generalizable_msg - ppf - (fun ppf () -> - fprintf ppf - "@[This expression's type contains type variables that can't 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 "@]" - | anythingElse -> - Typemod.super_report_error_no_wrap_printing_env ppf anythingElse - -let report_error env ppf err = - Printtyp.wrap_printing_env env (fun () -> report_error ppf err) - -(* This will be called in super_main. This is how you'd override the default error printer from the compiler & register new error_of_exn handlers *) -let setup () = - Location.register_error_of_exn - (function - | Typemod.Error (loc, env, err) -> - Some (Super_location.error_of_printer loc (report_error env) err) - | Typemod.Error_forward err -> - Some err - | _ -> - None - ) diff --git a/jscomp/super_errors/super_typetexp.ml b/jscomp/super_errors/super_typetexp.ml deleted file mode 100644 index 2076329415..0000000000 --- a/jscomp/super_errors/super_typetexp.ml +++ /dev/null @@ -1,120 +0,0 @@ -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 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 fold_descr fold get_name f = fold (fun descr acc -> f (get_name descr) acc) -let fold_constructors x = fold_descr Env.fold_constructors (fun d -> d.cstr_name) x -let fold_labels x = fold_descr Env.fold_labels (fun d -> d.lbl_name) x - -(* taken from https://github.com/rescript-lang/ocaml/blob/d4144647d1bf9bc7dc3aadc24c25a7efa3a67915/typing/typetexp.ml#L918 *) -(* modified branches are commented *) -let report_error env ppf = function - | Typetexp.Unbound_type_constructor lid -> - (* modified *) - Format.fprintf ppf "@[This type constructor, `%a`, can't be found.@ " Printtyp.longident lid; - let has_candidate = 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_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; - 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 list it in bsconfig.json?@,\ - - @[Did you run `rescript build` instead of `rescript build -with-deps`@ (latter builds third-parties)@]?\ - @]@,\ - - Did you include the file's directory in bsconfig.json?@]\ - @]" - Printtyp.longident lid - end - end; - 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; - Typetexp.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; - Typetexp.spellcheck ppf fold_labels env lid - | anythingElse -> - Typetexp.report_error env ppf anythingElse - -(* This will be called in super_main. This is how you'd override the default error printer from the compiler & register new error_of_exn handlers *) -let setup () = - Location.register_error_of_exn - (function - | Typetexp.Error (loc, env, err) -> - Some (Super_location.error_of_printer loc (report_error env) err) - (* typetexp doesn't expose Error_forward *) - (* | Error_forward err -> - Some err *) - | _ -> - None - )