From 8c1a47a9156299885620d73b47cec426d8d69664 Mon Sep 17 00:00:00 2001 From: Antonio Nuno Monteiro Date: Tue, 28 Nov 2023 19:02:55 -0800 Subject: [PATCH] fix: improve Melange errors in the compiler core (#941) * fix: improve Melange errors in the compiler core * fix tests * chore: add changelog entry --- Changes.md | 2 + bin/melc.ml | 4 +- jscomp/common/external_ffi_types.ml | 32 +++---- jscomp/common/external_ffi_types.mli | 2 +- jscomp/core/ast_config.ml | 4 +- jscomp/core/ast_payload.ml | 114 +++++++++++++------------ jscomp/core/ast_payload.mli | 2 +- jscomp/core/mel_ast_invariant.ml | 9 +- test/blackbox-tests/legacy-ounit-cmd.t | 6 +- test/blackbox-tests/mel-errors.t | 105 +++++++++++++++++++++++ 10 files changed, 193 insertions(+), 87 deletions(-) create mode 100644 test/blackbox-tests/mel-errors.t diff --git a/Changes.md b/Changes.md index 66c1145020..cc79853588 100644 --- a/Changes.md +++ b/Changes.md @@ -60,6 +60,8 @@ Unreleased [#928](https://github.com/melange-re/melange/pull/928), [#931](https://github.com/melange-re/melange/pull/931), [#936](https://github.com/melange-re/melange/pull/936)) +- Improve error messages in the Melange compiler core + ([#941](https://github.com/melange-re/melange/pull/941)) - Fix a typo in `Node.node_module` (pa{r,}rent) [#929](https://github.com/melange-re/melange/pull/929) - BREAKING(runtime): Remove `Js.null_undefined` in favor of `Js.nullable` diff --git a/bin/melc.ml b/bin/melc.ml index 2cc3a529ce..c911dc562d 100644 --- a/bin/melc.ml +++ b/bin/melc.ml @@ -403,14 +403,14 @@ let file_level_flags_handler (e : Parsetree.expression option) = ( List.map ~f:(fun (e: Parsetree.expression) -> match e.pexp_desc with | Pexp_constant (Pconst_string(name,_,_)) -> name - | _ -> Location.raise_errorf ~loc:e.pexp_loc "string literal expected" ) args) + | _ -> Location.raise_errorf ~loc:e.pexp_loc "Flags must be a literal array of strings") args) in let argv = Melc_cli.normalize_argv (Array.of_list (Sys.argv.(0) :: args)) in (match Cmdliner.Cmd.eval ~argv melc_cmd with | c when c = Cmdliner.Cmd.Exit.ok -> () | _c -> Location.raise_errorf ~loc:pexp_loc "Invalid configuration") | Some e -> - Location.raise_errorf ~loc:e.pexp_loc "string array expected" + Location.raise_errorf ~loc:e.pexp_loc "Flags must be a literal array of strings" let () = Melangelib.Initialization.Global.run (); diff --git a/jscomp/common/external_ffi_types.ml b/jscomp/common/external_ffi_types.ml index 04698897bd..ea3e0ed979 100644 --- a/jscomp/common/external_ffi_types.ml +++ b/jscomp/common/external_ffi_types.ml @@ -142,28 +142,23 @@ let valid_ident (s : string) = let is_package_relative_path (x : string) = String.starts_with x ~prefix:"./" || String.starts_with x ~prefix:"../" -let valid_global_name ?loc txt = +let valid_global_name ~loc txt = if not (valid_ident txt) then let v = String.split_by ~keep_empty:true (fun x -> x = '.') txt in List.iter ~f:(fun s -> if not (valid_ident s) then - Location.raise_errorf ?loc "Not a valid global name %s" txt) + Location.raise_errorf ~loc "%S isn't a valid JavaScript identifier" + txt) v -(* We lose 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 = +let check_external_module_name ~loc x = match x with | { bundle = ""; _ } | { module_bind_name = Phint_name ""; _ } -> - Location.raise_errorf ?loc "empty name encountered" + Location.raise_errorf ~loc "`@mel.module' name cannot be empty" | _ -> () -let check_ffi ?loc ffi : bool = +let check_ffi ~loc ffi : bool = let xrelative = ref false in let upgrade bool = if not !xrelative then xrelative := bool in (match ffi with @@ -172,17 +167,16 @@ let check_ffi ?loc ffi : bool = Option.iter (fun name -> upgrade (is_package_relative_path name.bundle)) external_module_name; - valid_global_name ?loc name - | Js_send { name; _ } - | Js_set { js_set_name = name; _ } - | Js_get { js_get_name = name; _ } -> - valid_method_name ?loc name + valid_global_name ~loc name + | Js_send _ | Js_set _ | Js_get _ -> + (* see https://github.com/rescript-lang/rescript-compiler/issues/2583 *) + () | 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 + check_external_module_name ~loc external_module_name | Js_new { external_module_name; name; _ } | Js_call { external_module_name; name; splice = _; scopes = _ } -> Option.iter @@ -190,10 +184,10 @@ let check_ffi ?loc ffi : bool = upgrade (is_package_relative_path external_module_name.bundle)) external_module_name; Option.iter - (fun name -> check_external_module_name ?loc name) + (fun name -> check_external_module_name ~loc name) external_module_name; - valid_global_name ?loc name); + valid_global_name ~loc name); !xrelative let to_string (t : t) = Marshal.to_string t [] diff --git a/jscomp/common/external_ffi_types.mli b/jscomp/common/external_ffi_types.mli index 47808f813c..766ab902d3 100644 --- a/jscomp/common/external_ffi_types.mli +++ b/jscomp/common/external_ffi_types.mli @@ -95,7 +95,7 @@ type t = private (* val name_of_ffi : external_spec -> string *) -val check_ffi : ?loc:Location.t -> external_spec -> bool +val check_ffi : loc:Location.t -> external_spec -> bool val to_string : t -> string val from_string : string -> t diff --git a/jscomp/core/ast_config.ml b/jscomp/core/ast_config.ml index f76ad37720..47760c3235 100644 --- a/jscomp/core/ast_config.ml +++ b/jscomp/core/ast_config.ml @@ -57,7 +57,7 @@ let rec iter_on_mel_config_stru (x : Parsetree.structure) = List.iter ~f:(fun x -> Ast_payload.table_dispatch !structural_config_table x |> ignore) - (Ast_payload.ident_or_record_as_config loc payload) + (Ast_payload.ident_or_record_as_config ~loc payload) (* [ppxlib] adds a wrapper like: [@@@ocaml.ppx.context ...] @@ -102,6 +102,6 @@ let rec iter_on_mel_config_sigi (x : Parsetree.signature) = List.iter ~f:(fun x -> Ast_payload.table_dispatch !signature_config_table x |> ignore) - (Ast_payload.ident_or_record_as_config loc payload) + (Ast_payload.ident_or_record_as_config ~loc payload) | { psig_desc = Psig_attribute _; _ } :: rest -> iter_on_mel_config_sigi rest | _ :: _ -> () diff --git a/jscomp/core/ast_payload.ml b/jscomp/core/ast_payload.ml index bc9c6b7827..b9afdd3ec3 100644 --- a/jscomp/core/ast_payload.ml +++ b/jscomp/core/ast_payload.ml @@ -31,62 +31,64 @@ type action = string Asttypes.loc * Parsetree.expression option (* None means punning is hit {[ { x } ]} otherwise it comes with a payload - {[ { x = exp }]} -*) + {[ { x = exp }]} *) -let unrecognizedConfigRecord loc text = - Location.prerr_warning loc (Warnings.Mel_derive_warning text) - -let ident_or_record_as_config loc (x : t) : - (string Location.loc * Parsetree.expression option) list = - match x with - | PStr - [ - { - pstr_desc = - Pstr_eval - ( { - pexp_desc = Pexp_record (label_exprs, with_obj); - pexp_loc = loc; - _; - }, - _ ); - _; - }; - ] -> ( - match with_obj with - | None -> - List.map - ~f:(fun u -> - match u with - | ( { Asttypes.txt = Longident.Lident name; loc }, - { - 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) - | _ -> Location.raise_errorf ~loc "Qualified label is not allowed") - label_exprs - | Some _ -> - unrecognizedConfigRecord loc "`with` is not supported, discarding"; - []) - | PStr - [ - { - pstr_desc = - Pstr_eval - ({ pexp_desc = Pexp_ident { loc = lloc; txt = Lident txt }; _ }, _); - _; - }; - ] -> - [ ({ Asttypes.txt; loc = lloc }, None) ] - | PStr [] -> [] - | _ -> - unrecognizedConfigRecord loc "invalid attribute config-record, ignoring"; - [] +let ident_or_record_as_config = + let exception Local of Location.t in + let error ?(loc = Location.none) more = + let msg = + let base = + "Unsupported attribute payload. Expected a configuration record literal" + in + match more with "" -> base | s -> Format.sprintf "%s %s" base s + in + Location.raise_errorf ~loc "%s" msg + in + fun ~loc (x : t) -> + match x with + | PStr + [ + { + pstr_desc = + Pstr_eval + ({ pexp_desc = Pexp_record (label_exprs, with_obj); _ }, _); + _; + }; + ] -> ( + match with_obj with + | None -> ( + try + List.map + ~f:(fun u -> + match u with + | ( { Location.txt = Longident.Lident name; loc }, + { + 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) + | { loc; _ }, _ -> raise (Local loc)) + label_exprs + with Local loc -> error ~loc "(qualified labels aren't supported)") + | Some { pexp_loc; _ } -> + error ~loc:pexp_loc "(`with' is not supported)") + | PStr + [ + { + pstr_desc = + Pstr_eval + ( { pexp_desc = Pexp_ident { loc = lloc; txt = Lident txt }; _ }, + _ ); + _; + }; + ] -> + [ ({ Asttypes.txt; loc = lloc }, None) ] + | PStr [] -> [] + | _ -> error ~loc "" let assert_bool_lit (e : Parsetree.expression) = match e.pexp_desc with @@ -94,7 +96,7 @@ let assert_bool_lit (e : Parsetree.expression) = | Pexp_construct ({ txt = Lident "false"; _ }, None) -> false | _ -> Location.raise_errorf ~loc:e.pexp_loc - "expect `true` or `false` in this field" + "Expected a boolean literal (`true' or `false')" let table_dispatch table (action : action) = match action with diff --git a/jscomp/core/ast_payload.mli b/jscomp/core/ast_payload.mli index 91ea80953a..5724d24e4a 100644 --- a/jscomp/core/ast_payload.mli +++ b/jscomp/core/ast_payload.mli @@ -30,7 +30,7 @@ type t = Parsetree.payload type action = string Asttypes.loc * Parsetree.expression option -val ident_or_record_as_config : Location.t -> t -> action list +val ident_or_record_as_config : loc:Location.t -> t -> action list val assert_bool_lit : Parsetree.expression -> bool val table_dispatch : diff --git a/jscomp/core/mel_ast_invariant.ml b/jscomp/core/mel_ast_invariant.ml index 07425137fb..48fb29de9e 100644 --- a/jscomp/core/mel_ast_invariant.ml +++ b/jscomp/core/mel_ast_invariant.ml @@ -34,7 +34,7 @@ let check_constant loc kind (const : Parsetree.constant) = | `pat -> if s = "j" then Location.raise_errorf ~loc - "Unicode string is not allowed in pattern match") + "Unicode strings cannot currently be used in pattern matching") | Pconst_integer (s, None) -> ( (* range check using int32 It is better to give a warning instead of error to avoid make people unhappy. @@ -44,7 +44,9 @@ let check_constant loc kind (const : Parsetree.constant) = try ignore (Int32.of_string s) with _ -> Location.prerr_warning loc Mel_integer_literal_overflow) | Pconst_integer (_, Some 'n') -> - Location.raise_errorf ~loc "literal with `n` suffix is not supported" + Location.raise_errorf ~loc + "`nativeint' is not currently supported in Melange. The `n' suffix \ + cannot be used." | _ -> () module Core_type = struct @@ -97,7 +99,8 @@ let emit_external_warnings : Ast_iterator.iterator = Parsetree.value_description) when not (Core_type.is_arity_one pval_type) -> Location.raise_errorf ~loc:pval_loc - "%%identity expect its type to be of form 'a -> 'b (arity 1)" + "The `%%identity' primitive type must take a single argument ('a \ + -> 'b)" | { pval_attributes; pval_loc; _ } -> if has_mel_attributes pval_attributes then print_unprocessed_alert pval_loc diff --git a/test/blackbox-tests/legacy-ounit-cmd.t b/test/blackbox-tests/legacy-ounit-cmd.t index a436923ee6..147d01006c 100644 --- a/test/blackbox-tests/legacy-ounit-cmd.t +++ b/test/blackbox-tests/legacy-ounit-cmd.t @@ -194,7 +194,7 @@ Skip over the temporary file name printed in the error trace $ melc -ppx melppx -bs-eval 'external f : int = "%identity"' 2>&1 | grep -v File 1 | external f : int = "%identity" ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - Error: %identity expect its type to be of form 'a -> 'b (arity 1) + Error: The `%identity' primitive type must take a single argument ('a -> 'b) $ melc -ppx melppx -bs-eval 'external f : int -> int = "%identity"' // Generated by Melange @@ -203,7 +203,7 @@ Skip over the temporary file name printed in the error trace $ melc -ppx melppx -bs-eval 'external f : int -> int -> int = "%identity"' 2>&1 | grep -v File 1 | external f : int -> int -> int = "%identity" ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - Error: %identity expect its type to be of form 'a -> 'b (arity 1) + Error: The `%identity' primitive type must take a single argument ('a -> 'b) $ melc -ppx melppx -bs-eval 'external f : (int -> int) -> int = "%identity"' // Generated by Melange @@ -212,7 +212,7 @@ Skip over the temporary file name printed in the error trace $ melc -ppx melppx -bs-eval 'external f : int -> (int-> int) = "%identity"' 2>&1 | grep -v File 1 | external f : int -> (int-> int) = "%identity" ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - Error: %identity expect its type to be of form 'a -> 'b (arity 1) + Error: The `%identity' primitive type must take a single argument ('a -> 'b) $ cat > x.ml < external foo_bar : diff --git a/test/blackbox-tests/mel-errors.t b/test/blackbox-tests/mel-errors.t new file mode 100644 index 0000000000..5ad3cf4428 --- /dev/null +++ b/test/blackbox-tests/mel-errors.t @@ -0,0 +1,105 @@ +Demonstrate PPX error messages + + $ . ./setup.sh + + $ cat > dune-project < (lang dune 3.8) + > (using melange 0.1) + > EOF + $ cat > dune < (melange.emit + > (target out) + > (emit_stdlib false) + > (preprocess (pps melange.ppx -alert -fragile))) + > EOF + + $ cat > x.ml < external join : string -> string = "join!me" + > EOF + $ dune build @melange + File "x.ml", line 1, characters 0-44: + 1 | external join : string -> string = "join!me" + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + Error: "join!me" isn't a valid JavaScript identifier + [1] + + $ cat > x.ml < external join : string -> string = "" [@@mel.module ""] + > EOF + $ dune build @melange + File "x.ml", line 1, characters 0-55: + 1 | external join : string -> string = "" [@@mel.module ""] + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + Error: `@mel.module' name cannot be empty + [1] + + $ cat > x.ml < [@@@mel.config { x with y = 1 }] + > EOF + $ dune build @melange + File "x.ml", line 1, characters 17-18: + 1 | [@@@mel.config { x with y = 1 }] + ^ + Error: Unsupported attribute payload. Expected a configuration record literal (`with' is not supported) + [1] + + $ cat > x.ml < [@@@mel.config { no_export = Not_bool }] + > EOF + $ dune build @melange + File "x.ml", line 1, characters 29-37: + 1 | [@@@mel.config { no_export = Not_bool }] + ^^^^^^^^ + Error: Expected a boolean literal (`true' or `false') + [1] + + $ cat > x.ml < let x = function + > | {j|x|j} -> () + > EOF + $ dune build @melange + File "x.ml", line 2, characters 4-11: + 2 | | {j|x|j} -> () + ^^^^^^^ + Error: Unicode strings cannot currently be used in pattern matching + [1] + + $ cat > x.ml < let x = 42n + > EOF + $ dune build @melange + File "x.ml", line 1, characters 8-11: + 1 | let x = 42n + ^^^ + Error: `nativeint' is not currently supported in Melange. The `n' suffix cannot be used. + [1] + + $ cat > x.ml < external cast: 'a -> 'b -> 'c = "%identity" + > EOF + $ dune build @melange + File "x.ml", line 1, characters 0-43: + 1 | external cast: 'a -> 'b -> 'c = "%identity" + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + Error: The `%identity' primitive type must take a single argument ('a -> 'b) + [1] + + $ cat > x.ml < [@@@mel.config { flags = [| 1; 2 |] }] + > EOF + $ dune build @melange + File "x.ml", line 1, characters 28-29: + 1 | [@@@mel.config { flags = [| 1; 2 |] }] + ^ + Error: Flags must be a literal array of strings + [1] + + $ cat > x.ml < [@@@mel.config { flags = [ ] }] + > EOF + $ dune build @melange + File "x.ml", line 1, characters 25-28: + 1 | [@@@mel.config { flags = [ ] }] + ^^^ + Error: Flags must be a literal array of strings + [1]