Keep location on type declarations.

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/located_errors@10454 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

13 files changed, 73 insertions, 26 deletions

diff --git a/.depend b/.depend
index f3b896447d..1430349ee3 100644
--- a/.depend
+++ b/.depend
@@ -104,8 +104,8 @@ typing/typedtree.cmi: typing/types.cmi typing/primitive.cmi typing/path.cmi \
 typing/typemod.cmi: typing/types.cmi typing/typedtree.cmi \
     parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \
     typing/includemod.cmi typing/ident.cmi typing/env.cmi
-typing/types.cmi: typing/primitive.cmi typing/path.cmi typing/ident.cmi \
-    parsing/asttypes.cmi
+typing/types.cmi: typing/primitive.cmi typing/path.cmi parsing/location.cmi \
+    typing/ident.cmi parsing/asttypes.cmi
 typing/typetexp.cmi: typing/types.cmi typing/path.cmi parsing/parsetree.cmi \
     parsing/longident.cmi parsing/location.cmi typing/env.cmi
 typing/unused_var.cmi: parsing/parsetree.cmi
@@ -147,12 +147,14 @@ typing/includecore.cmx: typing/types.cmx typing/typedtree.cmx \
     typing/btype.cmx parsing/asttypes.cmi typing/includecore.cmi
 typing/includemod.cmo: typing/types.cmi typing/typedtree.cmi utils/tbl.cmi \
     typing/subst.cmi typing/printtyp.cmi typing/path.cmi typing/mtype.cmi \
-    utils/misc.cmi typing/includecore.cmi typing/includeclass.cmi \
-    typing/ident.cmi typing/env.cmi typing/ctype.cmi typing/includemod.cmi
+    utils/misc.cmi parsing/location.cmi typing/includecore.cmi \
+    typing/includeclass.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \
+    typing/includemod.cmi
 typing/includemod.cmx: typing/types.cmx typing/typedtree.cmx utils/tbl.cmx \
     typing/subst.cmx typing/printtyp.cmx typing/path.cmx typing/mtype.cmx \
-    utils/misc.cmx typing/includecore.cmx typing/includeclass.cmx \
-    typing/ident.cmx typing/env.cmx typing/ctype.cmx typing/includemod.cmi
+    utils/misc.cmx parsing/location.cmx typing/includecore.cmx \
+    typing/includeclass.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \
+    typing/includemod.cmi
 typing/mtype.cmo: typing/types.cmi typing/subst.cmi typing/path.cmi \
     typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/clflags.cmi \
     typing/btype.cmi parsing/asttypes.cmi typing/mtype.cmi
@@ -175,10 +177,10 @@ typing/parmatch.cmx: utils/warnings.cmx typing/types.cmx typing/typedtree.cmx \
     typing/parmatch.cmi
 typing/path.cmo: typing/ident.cmi typing/path.cmi
 typing/path.cmx: typing/ident.cmx typing/path.cmi
-typing/predef.cmo: typing/types.cmi typing/path.cmi typing/ident.cmi \
-    typing/btype.cmi parsing/asttypes.cmi typing/predef.cmi
-typing/predef.cmx: typing/types.cmx typing/path.cmx typing/ident.cmx \
-    typing/btype.cmx parsing/asttypes.cmi typing/predef.cmi
+typing/predef.cmo: typing/types.cmi typing/path.cmi parsing/location.cmi \
+    typing/ident.cmi typing/btype.cmi parsing/asttypes.cmi typing/predef.cmi
+typing/predef.cmx: typing/types.cmx typing/path.cmx parsing/location.cmx \
+    typing/ident.cmx typing/btype.cmx parsing/asttypes.cmi typing/predef.cmi
 typing/primitive.cmo: utils/misc.cmi typing/primitive.cmi
 typing/primitive.cmx: utils/misc.cmx typing/primitive.cmi
 typing/printtyp.cmo: typing/types.cmi typing/primitive.cmi typing/predef.cmi \
@@ -196,9 +198,11 @@ typing/stypes.cmo: typing/typedtree.cmi typing/printtyp.cmi \
 typing/stypes.cmx: typing/typedtree.cmx typing/printtyp.cmx \
     parsing/location.cmx utils/clflags.cmx typing/annot.cmi typing/stypes.cmi
 typing/subst.cmo: typing/types.cmi utils/tbl.cmi typing/path.cmi \
-    utils/misc.cmi typing/ident.cmi typing/btype.cmi typing/subst.cmi
+    utils/misc.cmi parsing/location.cmi typing/ident.cmi typing/btype.cmi \
+    typing/subst.cmi
 typing/subst.cmx: typing/types.cmx utils/tbl.cmx typing/path.cmx \
-    utils/misc.cmx typing/ident.cmx typing/btype.cmx typing/subst.cmi
+    utils/misc.cmx parsing/location.cmx typing/ident.cmx typing/btype.cmx \
+    typing/subst.cmi
 typing/typeclass.cmo: utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \
     typing/typedtree.cmi typing/typedecl.cmi typing/typecore.cmi \
     typing/subst.cmi typing/stypes.cmi typing/printtyp.cmi typing/predef.cmi \
@@ -264,9 +268,11 @@ typing/typemod.cmx: typing/typetexp.cmx typing/types.cmx typing/typedtree.cmx \
     utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi typing/annot.cmi \
     typing/typemod.cmi
 typing/types.cmo: typing/primitive.cmi typing/path.cmi utils/misc.cmi \
-    typing/ident.cmi parsing/asttypes.cmi typing/types.cmi
+    parsing/location.cmi typing/ident.cmi parsing/asttypes.cmi \
+    typing/types.cmi
 typing/types.cmx: typing/primitive.cmx typing/path.cmx utils/misc.cmx \
-    typing/ident.cmx parsing/asttypes.cmi typing/types.cmi
+    parsing/location.cmx typing/ident.cmx parsing/asttypes.cmi \
+    typing/types.cmi
 typing/typetexp.cmo: utils/warnings.cmi typing/types.cmi utils/tbl.cmi \
     typing/printtyp.cmi typing/path.cmi parsing/parsetree.cmi utils/misc.cmi \
     parsing/longident.cmi parsing/location.cmi typing/env.cmi \
diff --git a/Makefile b/Makefile
index 7c7607f3ab..4b8b9a5d25 100644
--- a/Makefile
+++ b/Makefile
@@ -113,6 +113,7 @@ OPTOBJS=$(OPTUTILS) $(PARSING) $(TYPING) $(COMP) $(ASMCOMP) $(OPTDRIVER)
 EXPUNGEOBJS=utils/misc.cmo utils/tbl.cmo \
   utils/config.cmo utils/clflags.cmo \
   typing/ident.cmo typing/path.cmo typing/types.cmo typing/btype.cmo \
+  utils/warnings.cmo parsing/linenum.cmo parsing/location.cmo \
   typing/predef.cmo bytecomp/runtimedef.cmo bytecomp/bytesections.cmo \
   bytecomp/dll.cmo bytecomp/meta.cmo bytecomp/symtable.cmo toplevel/expunge.cmo
 
diff --git a/parsing/location.mli b/parsing/location.mli
index a496a35506..4d879e3adc 100644
--- a/parsing/location.mli
+++ b/parsing/location.mli
@@ -55,3 +55,5 @@ val echo_eof: unit -> unit
 val reset: unit -> unit
 
 val highlight_locations: formatter -> t -> t -> bool
+
+val print: formatter -> t -> unit
diff --git a/typing/ctype.ml b/typing/ctype.ml
index b65de95476..d9fbb557a8 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -3383,6 +3383,7 @@ let nondep_type_decl env mid id is_covariant decl =
       type_manifest = tm;
       type_private = priv;
       type_variance = decl.type_variance;
+      type_loc = decl.type_loc;
     }
   with Not_found ->
     clear_hash ();
diff --git a/typing/includemod.ml b/typing/includemod.ml
index 099723aa45..75c2c299f4 100644
--- a/typing/includemod.ml
+++ b/typing/includemod.ml
@@ -338,14 +338,23 @@ let include_err ppf = function
        (value_description id) d1 (value_description id) d2
   | Type_declarations(id, d1, d2, errs) ->
       fprintf ppf
-       "@[<hv 2>Type declarations do not match:@ \
-        %a@;<1 -2>is not included in@ %a@]"
-       (type_declaration id) d1
-       (type_declaration id) d2;
+        "@[<hv 2>Type declarations do not match:@ %a@;<1 -2>is not included in@ %a@]"
+        (type_declaration id) d1
+        (type_declaration id) d2;
+      if d1.type_loc.Location.loc_start <> Lexing.dummy_pos then begin
+        fprintf ppf "@.";
+        Location.print ppf d1.type_loc;
+        fprintf ppf "First declaration"
+      end;
+      if d2.type_loc.Location.loc_start <> Lexing.dummy_pos then begin
+        fprintf ppf "@.";
+        Location.print ppf d2.type_loc;
+        fprintf ppf "Second declaration"
+      end;
       List.iter
         (fun err -> fprintf ppf "@.%s."
             (Includecore.report_type_mismatch "the first" "the second" err))
-        errs
+        errs;
   | Exception_declarations(id, d1, d2) ->
       fprintf ppf
        "@[<hv 2>Exception declarations do not match:@ \
diff --git a/typing/predef.ml b/typing/predef.ml
index 728eb57295..eef77e39df 100644
--- a/typing/predef.ml
+++ b/typing/predef.ml
@@ -89,6 +89,7 @@ let build_initial_env add_type add_exception empty_env =
     {type_params = [];
      type_arity = 0;
      type_kind = Type_abstract;
+     type_loc = Location.none;
      type_private = Public;
      type_manifest = None;
      type_variance = []}
@@ -96,6 +97,7 @@ let build_initial_env add_type add_exception empty_env =
     {type_params = [];
      type_arity = 0;
      type_kind = Type_variant(["false", []; "true", []]);
+     type_loc = Location.none;
      type_private = Public;
      type_manifest = None;
      type_variance = []}
@@ -103,6 +105,7 @@ let build_initial_env add_type add_exception empty_env =
     {type_params = [];
      type_arity = 0;
      type_kind = Type_variant(["()", []]);
+     type_loc = Location.none;
      type_private = Public;
      type_manifest = None;
      type_variance = []}
@@ -110,6 +113,7 @@ let build_initial_env add_type add_exception empty_env =
     {type_params = [];
      type_arity = 0;
      type_kind = Type_variant [];
+     type_loc = Location.none;
      type_private = Public;
      type_manifest = None;
      type_variance = []}
@@ -118,6 +122,7 @@ let build_initial_env add_type add_exception empty_env =
     {type_params = [tvar];
      type_arity = 1;
      type_kind = Type_abstract;
+     type_loc = Location.none;
      type_private = Public;
      type_manifest = None;
      type_variance = [true, true, true]}
@@ -127,6 +132,7 @@ let build_initial_env add_type add_exception empty_env =
      type_arity = 1;
      type_kind =
        Type_variant(["[]", []; "::", [tvar; type_list tvar]]);
+     type_loc = Location.none;
      type_private = Public;
      type_manifest = None;
      type_variance = [true, false, false]}
@@ -137,6 +143,7 @@ let build_initial_env add_type add_exception empty_env =
      ];
      type_arity = 6;
      type_kind = Type_abstract;
+     type_loc = Location.none;
      type_private = Public;
      type_manifest = None;
      type_variance = [
@@ -149,6 +156,7 @@ let build_initial_env add_type add_exception empty_env =
     {type_params = [tvar];
      type_arity = 1;
      type_kind = Type_variant(["None", []; "Some", [tvar]]);
+     type_loc = Location.none;
      type_private = Public;
      type_manifest = None;
      type_variance = [true, false, false]}
@@ -157,6 +165,7 @@ let build_initial_env add_type add_exception empty_env =
     {type_params = [tvar];
      type_arity = 1;
      type_kind = Type_abstract;
+     type_loc = Location.none;
      type_private = Public;
      type_manifest = None;
      type_variance = [true, false, false]}
diff --git a/typing/subst.ml b/typing/subst.ml
index 6aa2766061..40cafb7bc3 100644
--- a/typing/subst.ml
+++ b/typing/subst.ml
@@ -183,6 +183,7 @@ let type_declaration s decl =
         end;
       type_private = decl.type_private;
       type_variance = decl.type_variance;
+      type_loc = if s.for_saving then Location.none else decl.type_loc;
     }
   in
   cleanup_types ();
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index de093cfc53..cea3a5c361 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -1015,7 +1015,9 @@ let temp_abbrev env id arity =
        type_kind = Type_abstract;
        type_private = Public;
        type_manifest = Some ty;
-       type_variance = List.map (fun _ -> true, true, true) !params}
+       type_variance = List.map (fun _ -> true, true, true) !params;
+       type_loc = Location.none;
+      }
       env
   in
   (!params, ty, env)
@@ -1226,7 +1228,9 @@ let class_infos define_class kind
      type_kind = Type_abstract;
      type_private = Public;
      type_manifest = Some obj_ty;
-     type_variance = List.map (fun _ -> true, true, true) obj_params}
+     type_variance = List.map (fun _ -> true, true, true) obj_params;
+     type_loc = cl.pci_loc;
+    }
   in
   let (cl_params, cl_ty) =
     Ctype.instance_parameterized_type params (Ctype.self_type typ)
@@ -1239,7 +1243,9 @@ let class_infos define_class kind
      type_kind = Type_abstract;
      type_private = Public;
      type_manifest = Some cl_ty;
-     type_variance = List.map (fun _ -> true, true, true) cl_params}
+     type_variance = List.map (fun _ -> true, true, true) cl_params;
+     type_loc = cl.pci_loc;
+    }
   in
   ((cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
     arity, pub_meths, List.rev !coercion_locs, expr) :: res,
diff --git a/typing/typecore.ml b/typing/typecore.ml
index d9213c232b..6121df0ce6 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -1594,6 +1594,7 @@ let rec type_exp env sexp =
         type_private = Public;
         type_manifest = None;
         type_variance = [];
+        type_loc = loc;
       }
       in
 
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 5cf54975d2..484f6f3d64 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -58,6 +58,7 @@ let enter_type env (name, sdecl) id =
         begin match sdecl.ptype_manifest with None -> None
         | Some _ -> Some(Ctype.newvar ()) end;
       type_variance = List.map (fun _ -> true, true, true) sdecl.ptype_params;
+      type_loc = sdecl.ptype_loc;
     }
   in
   Env.add_type id decl env
@@ -187,6 +188,7 @@ let transl_declaration env (name, sdecl) id =
             Some (transl_simple_type env no_row sty)
         end;
       type_variance = List.map (fun _ -> true, true, true) params;
+      type_loc = sdecl.ptype_loc;
     } in
 
   (* Check constraints *)
@@ -800,6 +802,7 @@ let transl_with_constraint env id row_path sdecl =
             Some(transl_simple_type env no_row sty)
         end;
       type_variance = [];
+      type_loc = sdecl.ptype_loc;
     }
   in
   begin match row_path with None -> ()
@@ -829,7 +832,9 @@ let abstract_type_decl arity =
       type_kind = Type_abstract;
       type_private = Public;
       type_manifest = None;
-      type_variance = replicate_list (true, true, true) arity } in
+      type_variance = replicate_list (true, true, true) arity;
+      type_loc = Location.none;
+     } in
   Ctype.end_def();
   generalize_decl decl;
   decl
diff --git a/typing/typemod.ml b/typing/typemod.ml
index c42315d356..2e72f83b3d 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -109,7 +109,9 @@ let merge_constraint initial_env loc sg lid constr =
             type_manifest = None;
             type_variance =
               List.map (fun (c,n) -> (not n, not c, not c))
-              sdecl.ptype_variance }
+              sdecl.ptype_variance;
+            type_loc = Location.none;
+           }
         and id_row = Ident.create (s^"#row") in
         let initial_env = Env.add_type id_row decl_row initial_env in
         let newdecl = Typedecl.transl_with_constraint
diff --git a/typing/types.ml b/typing/types.ml
index 5996719d4d..e11755613e 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -142,7 +142,9 @@ type type_declaration =
     type_kind: type_kind;
     type_private: private_flag;
     type_manifest: type_expr option;
-    type_variance: (bool * bool * bool) list }
+    type_variance: (bool * bool * bool) list;
+    type_loc: Location.t;
+   }
             (* covariant, contravariant, weakly contravariant *)
 
 and type_kind =
diff --git a/typing/types.mli b/typing/types.mli
index a4c6408457..fa130f8a4d 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -139,7 +139,9 @@ type type_declaration =
     type_kind: type_kind;
     type_private: private_flag;
     type_manifest: type_expr option;
-    type_variance: (bool * bool * bool) list }
+    type_variance: (bool * bool * bool) list;
+    type_loc: Location.t;
+   }
             (* covariant, contravariant, weakly contravariant *)
 
 and type_kind =