fix: improve Melange errors in the compiler core (#941)

* fix: improve Melange errors in the compiler core * fix tests * chore: add changelog entry
melange-re · Nov 29, 2023 · 8c1a47a · 8c1a47a
1 parent a53863d
commit 8c1a47a
Show file tree

Hide file tree

Showing 10 changed files with 193 additions and 87 deletions.
diff --git 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
@@ -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
@@ -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,28 +167,27 @@ 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
         (fun external_module_name ->
           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
@@ -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
@@ -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
@@ -31,70 +31,72 @@ 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
   | Pexp_construct ({ txt = Lident "true"; _ }, None) -> true
   | 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
@@ -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
@@ -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
@@ -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 <<EOF
   > external foo_bar :