Better type error location in presence of constraints

Changes

@@ -457,6 +457,8 @@ Bug fixes:
   (Jérémie Dimino, Thomas Refis)
 - GPR#405: fix compilation under Visual Studio 2015
   (David Allsopp)
+- GPR#441: better type error location in presence of type constraints
+  (Thomas Refis, report by Arseniy Alekseyev)
 
 Features wishes:
 - PR#4518, GPR#29: change location format for reporting errors in ocamldoc

testsuite/tests/typing-gadts/pr6690.ml.reference

@@ -5,18 +5,16 @@ type 'a local_visit_action
 type ('a, 'result, 'visit_action) context =
     Local : ('a, 'a * insert, 'a local_visit_action) context
   | Global : ('a, 'a, 'a visit_action) context
-#             Characters 11-166:
-  ..........(type visit_action)
-      : (_, _, visit_action) context -> _ -> visit_action =
+#             Characters 35-166:
+  ....: (_, _, visit_action) context -> _ -> visit_action =
     function
     | Local -> fun _ -> raise Exit
     | Global -> fun _ -> raise Exit
 Error: This expression has type ($0, $0 * insert, 'a) context -> 'b -> 'a
        but an expression was expected of type 'c
        The type constructor $0 would escape its scope
-#             Characters 11-174:
-  ..........(type visit_action)
-      : ('a, 'result, visit_action) context -> 'a -> visit_action =
+#             Characters 35-174:
+  ....: ('a, 'result, visit_action) context -> 'a -> visit_action =
     function
     | Local -> fun _ -> raise Exit
     | Global -> fun _ -> raise Exit

testsuite/tests/typing-gadts/test.ml.principal.reference

@@ -360,9 +360,9 @@ Error: This expression has type t = < foo : int; .. >
        but an expression was expected of type < bar : int; foo : int >
        Type $0 = < bar : int; .. > is not compatible with type < bar : int > 
        The first object type has an abstract row, it cannot be closed
-#         Characters 98-99:
+#         Characters 97-121:
     (x:<foo:int;bar:int;..>)
-     ^
+    ^^^^^^^^^^^^^^^^^^^^^^^^
 Error: This expression has type < bar : int; foo : int; .. >
        but an expression was expected of type 'a
        The type constructor $1 would escape its scope

testsuite/tests/typing-gadts/test.ml.reference

@@ -347,9 +347,9 @@ Error: This expression has type t = < foo : int; .. >
        but an expression was expected of type < bar : int; foo : int >
        Type $0 = < bar : int; .. > is not compatible with type < bar : int > 
        The first object type has an abstract row, it cannot be closed
-#         Characters 98-99:
+#         Characters 97-121:
     (x:<foo:int;bar:int;..>)
-     ^
+    ^^^^^^^^^^^^^^^^^^^^^^^^
 Error: This expression has type < bar : int; foo : int; .. >
        but an expression was expected of type 'a
        The type constructor $1 would escape its scope

typing/typecore.ml

@@ -1866,12 +1866,33 @@ let duplicate_ident_types loc caselist env =
      to keep the same internal 'slot' to track unused opens. *)
   List.fold_left (fun env s -> Env.update_value s upd env) env idents
 
+
+(* Getting proper location of already typed expressions.
+
+   Used to avoid confusing locations on type error messages in presence of
+   type constraints.
+   For example:
+
+       (* Before patch *)
+       # let x : string = (5 : int);;
+                           ^
+       (* After patch *)
+       # let x : string = (5 : int);;
+                          ^^^^^^^^^
+*)
+let proper_exp_loc exp =
+  let rec aux = function
+    | [] -> exp.exp_loc
+    | ((Texp_constraint _ | Texp_coerce _), loc, _) :: _ -> loc
+    | _ :: rest -> aux rest
+  in
+  aux exp.exp_extra
+
 (* Typing of expressions *)
 
 let unify_exp env exp expected_ty =
-  (* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type
-    Printtyp.raw_type_expr expected_ty; *)
-    unify_exp_types exp.exp_loc env exp.exp_type expected_ty
+  let loc = proper_exp_loc exp in
+  unify_exp_types loc env exp.exp_type expected_ty
 
 let rec type_exp ?recarg env sexp =
   (* We now delegate everything to type_expect *)