flambda-backend: Honor [@error_message] attribute even when its location is ghost (#2750)

* Add regression test

* Fix ghost location bug

Author: ncik-roberts

testsuite/tests/ppx-error-message/ppx_error_message.ml

@@ -0,0 +1,53 @@
+open Ast_mapper
+
+(* Assert statically that a string that appears in the source text
+   is alphabetically ordered. This is a bit contrived so that we
+   can exercise [@ocaml.error_message].
+*)
+
+let () =
+  register "sorted" (fun _ ->
+    { default_mapper with expr = fun self expr ->
+      match expr.pexp_desc with
+      | Pexp_extension
+         ( { txt = "sorted" },
+           PStr
+             [ { pstr_desc =
+                   Pstr_eval
+                     ( { pexp_desc = Pexp_constant (Pconst_string (str, loc, _)) }
+                     , _ ) } ] )
+         ->
+        (* Use a ghost location, as is typical for ppxes *)
+        let loc = { loc with loc_ghost = true } in
+        let sorted =
+          String.to_seq str
+          |> List.of_seq
+          |> List.sort Char.compare
+          |> List.to_seq
+          |> String.of_seq
+        in
+        Ast_helper.with_default_loc loc (fun () ->
+          Ast_helper.Exp.apply
+            (Ast_helper.Exp.ident { txt = Lident "ignore"; loc})
+            [ Nolabel,
+                Ast_helper.Exp.attr
+                  (Ast_helper.Exp.constraint_
+                    (Ast_helper.Exp.variant sorted None)
+                    (Ast_helper.Typ.variant
+                      [ Ast_helper.Rf.tag { txt = str; loc } true [] ]
+                      Closed
+                      None ))
+                  (Ast_helper.Attr.mk
+                     { txt = "ocaml.error_message"; loc }
+                     (PStr
+                       [ Ast_helper.Exp.constant
+                           (Ast_helper.Const.string
+                             (Printf.sprintf
+                               "The %s string is not in alphabetical order."
+                               str))
+                         |> Ast_helper.Str.eval
+                        ]))
+            ])
+      | _ -> default_mapper.expr self expr
+    }
+  )

testsuite/tests/ppx-error-message/test.compilers.reference

@@ -0,0 +1,9 @@
+File "test.ml", line 20, characters 21-46:
+20 |   let () = [%sorted "not_in_alphabetical_order"]
+                          ^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This expression has type [> `___aaabcdeehiillnnooprrtt ]
+       but an expression was expected of type
+         [ `not_in_alphabetical_order ]
+       The not_in_alphabetical_order string is not in alphabetical order.
+       The second variant type does not allow tag(s)
+       `___aaabcdeehiillnnooprrtt

testsuite/tests/ppx-error-message/test.ml

@@ -0,0 +1,23 @@
+(* TEST
+ readonly_files = "ppx_error_message.ml";
+ include ocamlcommon;
+ setup-ocamlc.byte-build-env;
+ program = "${test_build_directory}/ppx_error_message.exe";
+ all_modules = "ppx_error_message.ml";
+ ocamlc.byte;
+ module = "test.ml";
+ flags = "-I ${test_build_directory} -ppx ${program}";
+ ocamlc_byte_exit_status = "2";
+ ocamlc.byte;
+ check-ocamlc.byte-output;
+*)
+
+module Good = struct
+  let () = [%sorted "abcd"]
+end
+
+module Bad = struct
+  let () = [%sorted "not_in_alphabetical_order"]
+end
+
+

typing/typecore.ml

@@ -4733,6 +4733,18 @@ let check_apply_prim_type prim typ =
       end
   | _ -> false
 
+(* The explanation is suppressed if the location is ghost (e.g. the construct is
+   in ppx-generated code), unless the explanation originates from the
+   [@error_message] attribute, which a ppx may reasonably have inserted itself
+   to get a better error message.
+*)
+let should_show_explanation ~explanation ~loc =
+  if not loc.Location.loc_ghost then true
+  else
+    match explanation with
+    | Error_message_attr _ -> true
+    | _ -> false
+
 (* Merge explanation to type clash error *)
 
 let with_explanation explanation f =
@@ -4741,7 +4753,7 @@ let with_explanation explanation f =
   | Some explanation ->
       try f ()
       with Error (loc', env', Expr_type_clash(err', None, exp'))
-        when not loc'.Location.loc_ghost ->
+        when should_show_explanation ~loc:loc' ~explanation ->
         let err = Expr_type_clash(err', Some explanation, exp') in
         raise (Error (loc', env', err))