PR#7315: refine some error locations (#736)

Changes

@@ -1,15 +1,19 @@
-Next version (tbd)
-------------
+Next version (tbd):
+-------------------
 
 (Changes that can break existing programs are marked with a "*")
 
-### Build system:
+### Compiler user-interface and warnings:
+
+- PR#7315, GPR#736: refine some error locations
+  (Gabriel Scherer and Alain Frisch, report by Matej Košík)
+
+### Compiler distribution build system:
 
 - GPR#729: Make sure ocamlnat is built with a $(EXE) extension, merge
   rules between Unix and Windows Makefiles
  (Sébastien Hinderer, review by Alain Frisch)
 
-
 OCaml 4.04.0:
 -------------
 

testsuite/tests/messages/Makefile

@@ -0,0 +1,3 @@
+BASEDIR=../..
+include $(BASEDIR)/makefiles/Makefile.expect
+include $(BASEDIR)/makefiles/Makefile.common

testsuite/tests/messages/precise_locations.ml

@@ -0,0 +1,93 @@
+type t = (unit, unit, unit, unit) bar
+;;
+(* PR#7315: we expect the error location on "bar" instead of "(...) bar" *)
+[%%expect{|
+Line _, characters 34-37:
+Error: Unbound type constructor bar
+|}];;
+
+function (x :
+#bar) -> ();;
+(* we expect the location on "bar" instead of "#bar" *)
+[%%expect{|
+Line _, characters 1-4:
+Error: Unbound class bar
+|}];;
+
+function
+#bar -> ()
+;;
+(* we expect the location on "bar" instead of "#bar" *)
+[%%expect{|
+Line _, characters 1-4:
+Error: Unbound type constructor bar
+|}];;
+
+new bar;;
+(* we expect the location on "bar" instead of "new bar" *)
+[%%expect{|
+Line _, characters 4-7:
+Error: Unbound class bar
+|}];;
+
+type t =
+  | Foo of unit [@deprecated]
+  | Bar;;
+#warnings "@3";;
+let x =
+Foo ();;
+(* "Foo ()": the whole construct, with arguments, is deprecated *)
+[%%expect{|
+type t = Foo of unit | Bar
+Line _, characters 0-6:
+Warning 3: deprecated: Foo
+Line _:
+Error: Some fatal warnings were triggered (1 occurrences)
+|}];;
+function
+Foo _ -> () | Bar -> ();;
+(* "Foo _", the whole construct is deprecated *)
+[%%expect{|
+Line _, characters 0-5:
+Warning 3: deprecated: Foo
+Line _:
+Error: Some fatal warnings were triggered (1 occurrences)
+|}];;
+
+
+open Foo;;
+(* the error location should be on "Foo" *)
+[%%expect{|
+Line _, characters 5-8:
+Error: Unbound module Foo
+|}];;
+
+#warnings "@33";; (* unused open statement *)
+include (struct
+open List
+end);;
+(* here we expect the error location to be
+   on "open List" as whole rather than "List" *)
+[%%expect{|
+Line _, characters 0-9:
+Warning 33: unused open List.
+Line _:
+Error: Some fatal warnings were triggered (1 occurrences)
+|}];;
+
+type unknown += Foo;;
+(* unknown, not the whole line *)
+[%%expect{|
+Line _, characters 5-12:
+Error: Unbound type constructor unknown
+|}];;
+
+type t = ..;;
+type t +=
+Foo = Foobar;;
+(* Foobar, not the whole line *)
+[%%expect{|
+type t = ..
+Line _, characters 6-12:
+Error: Unbound constructor Foobar
+|}];;

testsuite/tests/typing-extensions/extensions.ml.reference

@@ -70,9 +70,9 @@ Error: The constructor M.A1 has type foo but was expected to be of type bar
   type foo += B3 = M.B1  (* Error: rebind private extension *)
                    ^^^^
 Error: The constructor M.B1 is private
-#     Characters 13-24:
+#     Characters 17-24:
   type foo += C = Unknown  (* Error: unbound extension *)
-              ^^^^^^^^^^^
+                  ^^^^^^^
 Error: Unbound constructor Unknown
 #                       module M : sig type foo type foo += A1 of int end
 type M.foo += A2 of int

testsuite/tests/typing-objects/pr6383.ml.reference

@@ -1,6 +1,6 @@
 
-# Characters 10-16:
+# Characters 11-16:
   let f (x: #M.foo) = 0;;
-            ^^^^^^
+             ^^^^^
 Error: Unbound module M
 # 

typing/typecore.ml

@@ -560,14 +560,14 @@ let rec build_as_type env p =
   | Tpat_array _ | Tpat_lazy _ -> p.pat_type
 
 let build_or_pat env loc lid =
-  let path, decl = Typetexp.find_type env loc lid
+  let path, decl = Typetexp.find_type env lid.loc lid.txt
   in
   let tyl = List.map (fun _ -> newvar()) decl.type_params in
   let row0 =
     let ty = expand_head env (newty(Tconstr(path, tyl, ref Mnil))) in
     match ty.desc with
       Tvariant row when static_row row -> row
-    | _ -> raise(Error(loc, env, Not_a_variant_type lid))
+    | _ -> raise(Error(lid.loc, env, Not_a_variant_type lid.txt))
   in
   let pats, fields =
     List.fold_left
@@ -598,7 +598,7 @@ let build_or_pat env loc lid =
       pats
   in
   match pats with
-    [] -> raise(Error(loc, env, Not_a_variant_type lid))
+    [] -> raise(Error(lid.loc, env, Not_a_variant_type lid.txt))
   | pat :: pats ->
       let r =
         List.fold_left
@@ -1358,7 +1358,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env
                   pat_extra = extra :: p.pat_extra}
         in k p)
   | Ppat_type lid ->
-      let (path, p,ty) = build_or_pat !env loc lid.txt in
+      let (path, p,ty) = build_or_pat !env loc lid in
       unify_pat_types loc !env ty expected_ty;
       k { p with pat_extra =
         (Tpat_type (path, lid), loc, sp.ppat_attributes) :: p.pat_extra }
@@ -1944,7 +1944,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
   match sexp.pexp_desc with
   | Pexp_ident lid ->
       begin
-        let (path, desc) = Typetexp.find_value env loc lid.txt in
+        let (path, desc) = Typetexp.find_value env lid.loc lid.txt in
         if !Clflags.annotations then begin
           let dloc = desc.Types.val_loc in
           let annot =
@@ -2683,7 +2683,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
                     Undefined_method (obj.exp_type, met, valid_methods)))
       end
   | Pexp_new cl ->
-      let (cl_path, cl_decl) = Typetexp.find_class env loc cl.txt in
+      let (cl_path, cl_decl) = Typetexp.find_class env cl.loc cl.txt in
       begin match cl_decl.cty_new with
           None ->
             raise(Error(loc, env, Virtual_class cl.txt))

typing/typedecl.ml

@@ -1329,7 +1329,7 @@ let transl_extension_constructor env type_path type_params
         in
           args, ret_type, Text_decl(targs, tret_type)
     | Pext_rebind lid ->
-        let cdescr = Typetexp.find_constructor env sext.pext_loc lid.txt in
+        let cdescr = Typetexp.find_constructor env lid.loc lid.txt in
         let usage =
           if cdescr.cstr_private = Private || priv = Public
           then Env.Positive else Env.Privatize
@@ -1437,7 +1437,8 @@ let transl_type_extension check_open env loc styext =
   reset_type_variables();
   Ctype.begin_def();
   let (type_path, type_decl) =
-    Typetexp.find_type env loc styext.ptyext_path.txt
+    let lid = styext.ptyext_path in
+    Typetexp.find_type env lid.loc lid.txt
   in
   begin
     match type_decl.type_kind with

typing/typetexp.ml

@@ -340,7 +340,7 @@ let rec transl_type env policy styp =
     let ty = newty (Ttuple (List.map (fun ctyp -> ctyp.ctyp_type) ctys)) in
     ctyp (Ttyp_tuple ctys) ty
   | Ptyp_constr(lid, stl) ->
-      let (path, decl) = find_type env styp.ptyp_loc lid.txt in
+      let (path, decl) = find_type env lid.loc lid.txt in
       let stl =
         match stl with
         | [ {ptyp_desc=Ptyp_any} as t ] when decl.type_arity > 1 ->
@@ -408,7 +408,7 @@ let rec transl_type env policy styp =
           let decl = Env.find_type path env in
           (path, decl, false)
         with Not_found ->
-          ignore (find_class env styp.ptyp_loc lid.txt); assert false
+          ignore (find_class env lid.loc lid.txt); assert false
       in
       if List.length stl <> decl.type_arity then
         raise(Error(styp.ptyp_loc, env,