Commits

camlspotter committed 688c810

path name simplif

  • Participants
  • Parent commits 397b59b
  • Branches path-simplif

Comments (0)

Files changed (20)

File driver/errors.ml

       fprintf ppf
       "In this program,@ variant constructors@ `%s and `%s@ \
        have the same hash value.@ Change one of them." l l'
-  | Typecore.Error(loc, err) ->
-      Location.print_error ppf loc; Typecore.report_error ppf err
-  | Typetexp.Error(loc, err) ->
-      Location.print_error ppf loc; Typetexp.report_error ppf err
-  | Typedecl.Error(loc, err) ->
-      Location.print_error ppf loc; Typedecl.report_error ppf err
-  | Typeclass.Error(loc, err) ->
-      Location.print_error ppf loc; Typeclass.report_error ppf err
-  | Includemod.Error err ->
+  | Typecore.Error(env, loc, err) ->
+      Location.print_error ppf loc; Typecore.report_error env ppf err
+  | Typetexp.Error(env, loc, err) ->
+      Location.print_error ppf loc; Typetexp.report_error env ppf err
+  | Typedecl.Error(env, loc, err) ->
+      Location.print_error ppf loc; Typedecl.report_error env ppf err
+  | Typeclass.Error(env, loc, err) ->
+      Location.print_error ppf loc; Typeclass.report_error env ppf err
+  | Includemod.Error (env, err) ->
       Location.print_error_cur_file ppf;
-      Includemod.report_error ppf err
-  | Typemod.Error(loc, err) ->
-      Location.print_error ppf loc; Typemod.report_error ppf err
+      Includemod.report_error env ppf err
+  | Typemod.Error(env, loc, err) ->
+      Location.print_error ppf loc; Typemod.report_error env ppf err
   | Translcore.Error(loc, err) ->
       Location.print_error ppf loc; Translcore.report_error ppf err
   | Translclass.Error(loc, err) ->

File driver/opterrors.ml

       fprintf ppf
       "In this program,@ variant constructors@ `%s and `%s@ \
        have the same hash value.@ Change one of them." l l'
-  | Typecore.Error(loc, err) ->
-      Location.print_error ppf loc; Typecore.report_error ppf err
-  | Typetexp.Error(loc, err) ->
-      Location.print_error ppf loc; Typetexp.report_error ppf err
-  | Typedecl.Error(loc, err) ->
-      Location.print_error ppf loc; Typedecl.report_error ppf err
-  | Typeclass.Error(loc, err) ->
-      Location.print_error ppf loc; Typeclass.report_error ppf err
-  | Includemod.Error err ->
+  | Typecore.Error(env, loc, err) ->
+      Location.print_error ppf loc; Typecore.report_error env ppf err
+  | Typetexp.Error(env, loc, err) ->
+      Location.print_error ppf loc; Typetexp.report_error env ppf err
+  | Typedecl.Error(env, loc, err) ->
+      Location.print_error ppf loc; Typedecl.report_error env ppf err
+  | Typeclass.Error(env, loc, err) ->
+      Location.print_error ppf loc; Typeclass.report_error env ppf err
+  | Includemod.Error (env, err) ->
       Location.print_error_cur_file ppf;
-      Includemod.report_error ppf err
-  | Typemod.Error(loc, err) ->
-      Location.print_error ppf loc; Typemod.report_error ppf err
+      Includemod.report_error env ppf err
+  | Typemod.Error(env, loc, err) ->
+      Location.print_error ppf loc; Typemod.report_error env ppf err
   | Translcore.Error(loc, err) ->
       Location.print_error ppf loc; Translcore.report_error ppf err
   | Translclass.Error(loc, err) ->

File ocamldoc/odoc_analyse.ml

       fprintf ppf
       "In this program,@ variant constructors@ `%s and `%s@ \
        have the same hash value." l l'
-  | Typecore.Error(loc, err) ->
-      Location.print_error ppf loc; Typecore.report_error ppf err
-  | Typetexp.Error(loc, err) ->
-      Location.print_error ppf loc; Typetexp.report_error ppf err
-  | Typedecl.Error(loc, err) ->
-      Location.print_error ppf loc; Typedecl.report_error ppf err
-  | Includemod.Error err ->
+  | Typecore.Error(env, loc, err) ->
+      Location.print_error ppf loc; Typecore.report_error env ppf err
+  | Typetexp.Error(env, loc, err) ->
+      Location.print_error ppf loc; Typetexp.report_error env ppf err
+  | Typedecl.Error(env, loc, err) ->
+      Location.print_error ppf loc; Typedecl.report_error env ppf err
+  | Includemod.Error (env, err) ->
       Location.print_error_cur_file ppf;
-      Includemod.report_error ppf err
-  | Typemod.Error(loc, err) ->
-      Location.print_error ppf loc; Typemod.report_error ppf err
+      Includemod.report_error env ppf err
+  | Typemod.Error(env, loc, err) ->
+      Location.print_error ppf loc; Typemod.report_error env ppf err
   | Translcore.Error(loc, err) ->
       Location.print_error ppf loc; Translcore.report_error ppf err
   | Sys_error msg ->
       Location.print_error_cur_file ppf;
       fprintf ppf "I/O error: %s" msg
-  | Typeclass.Error(loc, err) ->
-      Location.print_error ppf loc; Typeclass.report_error ppf err
+  | Typeclass.Error(env, loc, err) ->
+      Location.print_error ppf loc; Typeclass.report_error env ppf err
   | Translclass.Error(loc, err) ->
       Location.print_error ppf loc; Translclass.report_error ppf err
   | Warnings.Errors (n) ->

File otherlibs/labltk/browser/searchid.ml

         end in
       try Typemod.transl_signature env sexp
       with Env.Error err -> []
-      | Typemod.Error (l,_) ->
+      | Typemod.Error (_,l,_) ->
           let start_c = l.loc_start.Lexing.pos_cnum in
           let end_c = l.loc_end.Lexing.pos_cnum in
           raise (Error (start_c - 8, end_c - 8))
-      | Typetexp.Error (l,_) ->
+      | Typetexp.Error (_,l,_) ->
           let start_c = l.loc_start.Lexing.pos_cnum in
           let end_c = l.loc_end.Lexing.pos_cnum in
           raise (Error (start_c - 8, end_c - 8))

File otherlibs/labltk/browser/typecheck.ml

             Syntaxerr.Unclosed(l,_,_,_) -> l
           | Syntaxerr.Other l -> l
           end
-      | Typecore.Error (l,err) ->
-          Typecore.report_error Format.std_formatter err; l
-      | Typeclass.Error (l,err) ->
-          Typeclass.report_error Format.std_formatter err; l
-      | Typedecl.Error (l, err) ->
-          Typedecl.report_error Format.std_formatter err; l
-      | Typemod.Error (l,err) ->
-          Typemod.report_error Format.std_formatter err; l
-      | Typetexp.Error (l,err) ->
-          Typetexp.report_error Format.std_formatter err; l
-      | Includemod.Error errl ->
-          Includemod.report_error Format.std_formatter errl; Location.none
+      | Typecore.Error (env, l,err) ->
+          Typecore.report_error env Format.std_formatter err; l
+      | Typeclass.Error (env, l,err) ->
+          Typeclass.report_error env Format.std_formatter err; l
+      | Typedecl.Error (env, l, err) ->
+          Typedecl.report_error env Format.std_formatter err; l
+      | Typemod.Error (env, l,err) ->
+          Typemod.report_error env Format.std_formatter err; l
+      | Typetexp.Error (env, l,err) ->
+          Typetexp.report_error env Format.std_formatter err; l
+      | Includemod.Error (env, errl) ->
+          Includemod.report_error env Format.std_formatter errl; Location.none
       | Env.Error err ->
           Env.report_error Format.std_formatter err; Location.none
       | Ctype.Tags(l, l') ->

File toplevel/toploop.ml

       Some (tree, None, rem)
   | _ -> None
 
+let pr_item env = Printtyp.under_env env (pr_item env)
+
 let rec item_list env = function
   | [] -> []
   | items ->
                 match str with
                 | [Tstr_eval exp] ->
                     let outv = outval_of_value newenv v exp.exp_type in
-                    let ty = Printtyp.tree_of_type_scheme exp.exp_type in
+                    let ty = 
+		      Printtyp.under_env newenv
+			Printtyp.tree_of_type_scheme exp.exp_type
+		    in
                     Ophr_eval (outv, ty)
                 | [] -> Ophr_signature []
                 | _ -> Ophr_signature (item_list newenv

File typing/includemod.ml

       Ctype.class_match_failure list
   | Unbound_modtype_path of Path.t
 
-exception Error of error list
+exception Error of Env.t * error list
 
 (* All functions "blah env x1 x2" check that x1 is included in x2,
    i.e. that x1 is the type of an implementation that fulfills the
   try
     Includecore.value_descriptions env vd1 vd2
   with Includecore.Dont_match ->
-    raise(Error[Value_descriptions(id, vd1, vd2)])
+    raise(Error(env, [Value_descriptions(id, vd1, vd2)]))
 
 (* Inclusion between type declarations *)
 
   let decl2 = Subst.type_declaration subst decl2 in
   if Includecore.type_declarations env id decl1 decl2
   then ()
-  else raise(Error[Type_declarations(id, decl1, decl2)])
+  else raise(Error(env,[Type_declarations(id, decl1, decl2)]))
 
 (* Inclusion between exception declarations *)
 
   let decl2 = Subst.exception_declaration subst decl2 in
   if Includecore.exception_declarations env decl1 decl2
   then ()
-  else raise(Error[Exception_declarations(id, decl1, decl2)])
+  else raise(Error(env,[Exception_declarations(id, decl1, decl2)]))
 
 (* Inclusion between class declarations *)
 
   let decl2 = Subst.cltype_declaration subst decl2 in
   match Includeclass.class_type_declarations env decl1 decl2 with
     []     -> ()
-  | reason -> raise(Error[Class_type_declarations(id, decl1, decl2, reason)])
+  | reason -> raise(Error(env, [Class_type_declarations(id, decl1, decl2, reason)]))
 
 let class_declarations env subst id decl1 decl2 =
   let decl2 = Subst.class_declaration subst decl2 in
   match Includeclass.class_declarations env decl1 decl2 with
     []     -> ()
-  | reason -> raise(Error[Class_declarations(id, decl1, decl2, reason)])
+  | reason -> raise(Error(env,[Class_declarations(id, decl1, decl2, reason)]))
 
 (* Expand a module type identifier when possible *)
 
   try
     Env.find_modtype_expansion path env
   with Not_found ->
-    raise(Error[Unbound_modtype_path path])
+    raise(Error(env, [Unbound_modtype_path path]))
 
 (* Extract name, kind and ident from a signature item *)
 
     try_modtypes env subst mty1 mty2
   with 
     Dont_match ->
-      raise(Error[Module_types(mty1, Subst.modtype subst mty2)])
-  | Error reasons ->
-      raise(Error(Module_types(mty1, Subst.modtype subst mty2) :: reasons))
+      raise(Error(env, [Module_types(mty1, Subst.modtype subst mty2)]))
+  | Error (env, reasons) ->
+      raise(Error(env, Module_types(mty1, Subst.modtype subst mty2) :: reasons))
 
 and try_modtypes env subst mty1 mty2 =
   match (mty1, mty2) with
       [] ->
         begin match unpaired with
             [] -> signature_components new_env subst (List.rev paired)
-          | _  -> raise(Error unpaired)
+          | _  -> raise(Error (env, unpaired))
         end
     | item2 :: rem ->
         let (id2, name2) = item_ident_name item2 in
         check_modtype_equiv env mty1 mty2
     | (Tmodtype_abstract, Tmodtype_manifest mty2) ->
         check_modtype_equiv env (Tmty_ident(Pident id)) mty2
-  with Error reasons ->
-    raise(Error(Modtype_infos(id, info1, info2) :: reasons))
+  with Error (env, reasons) ->
+    raise(Error(env, Modtype_infos(id, info1, info2) :: reasons))
 
 and check_modtype_equiv env mty1 mty2 =
   match
      modtypes env Subst.identity mty2 mty1)
   with
     (Tcoerce_none, Tcoerce_none) -> ()
-  | (_, _) -> raise(Error [Modtype_permutation])
+  | (_, _) -> raise(Error (env, [Modtype_permutation]))
 
 (* Simplified inclusion check between module types (for Env) *)
 
   try
     ignore(modtypes env Subst.identity
                     (Mtype.strengthen env mty1 path1) mty2)
-  with Error reasons ->
+  with Error (env, reasons) ->
     raise Not_found
 
 let _ = Env.check_modtype_inclusion := check_modtype_inclusion
 let compunit impl_name impl_sig intf_name intf_sig =
   try
     signatures Env.initial Subst.identity impl_sig intf_sig
-  with Error reasons ->
-    raise(Error(Interface_mismatch(impl_name, intf_name) :: reasons))
+  with Error (env, reasons) ->
+    raise(Error(env, Interface_mismatch(impl_name, intf_name) :: reasons))
 
 (* Hide the substitution parameter to the outside world *)
 
       let print_errs ppf errs =
          List.iter (fun err -> fprintf ppf "@ %a" include_err err) errs in
       fprintf ppf "@[<v>%a%a@]" include_err err print_errs errs
+
+let report_error env ppf = 
+  Printtyp.under_env env (report_error ppf)

File typing/includemod.mli

       Ctype.class_match_failure list
   | Unbound_modtype_path of Path.t
 
-exception Error of error list
+exception Error of Env.t * error list
 
-val report_error: formatter -> error list -> unit
+val report_error: Env.t -> formatter -> error list -> unit

File typing/printtyp.ml

 
 let ident_pervasive = Ident.create_persistent "Pervasives"
 
-let rec tree_of_path = function
+let env_ref = ref Env.empty
+let opened_paths = ref []
+
+let rec get_opened_paths acc = function
+  | Env.Env_empty -> acc
+  | Env.Env_value (summary, _, _) 
+  | Env.Env_type (summary, _, _)
+  | Env.Env_exception (summary, _, _)
+  | Env.Env_module (summary, _, _)
+  | Env.Env_modtype (summary, _, _)
+  | Env.Env_class (summary, _, _)
+  | Env.Env_cltype (summary, _, _) -> 
+      get_opened_paths acc summary
+  | Env.Env_open (summary, p) -> 
+      get_opened_paths (p :: acc) summary
+;;
+
+let under_env env f v =
+  env_ref := env;
+  opened_paths := get_opened_paths [] (Env.summary env);
+  try 
+    let res = f v in 
+    env_ref := Env.empty; opened_paths := [];
+    res 
+  with
+  | e -> 
+      env_ref := Env.empty; opened_paths := [];
+      raise e
+
+let is_path_open p =
+  match p with
+  | Pident id when Ident.same id ident_pervasive -> true
+  | _ -> List.mem p !opened_paths 
+    
+let rec tree_of_path is_path_open = function
   | Pident id ->
       Oide_ident (Ident.name id)
-  | Pdot(Pident id, s, pos) when Ident.same id ident_pervasive ->
+  | Pdot(p, s, pos) when is_path_open p ->
       Oide_ident s
   | Pdot(p, s, pos) ->
-      Oide_dot (tree_of_path p, s)
+      Oide_dot (tree_of_path is_path_open p, s)
   | Papply(p1, p2) ->
-      Oide_apply (tree_of_path p1, tree_of_path p2)
+      Oide_apply (tree_of_path is_path_open p1, tree_of_path is_path_open p2)
 
-let rec path ppf = function
+let rec path is_path_open ppf = function
   | Pident id ->
       ident ppf id
-  | Pdot(Pident id, s, pos) when Ident.same id ident_pervasive ->
+  | Pdot(p, s, pos) when is_path_open p ->
       fprintf ppf "%s" s
   | Pdot(p, s, pos) ->
-      fprintf ppf "%a.%s" path p s
+      fprintf ppf "%a.%s" (path is_path_open) p s
   | Papply(p1, p2) ->
-      fprintf ppf "%a(%a)" path p1 path p2
+      fprintf ppf "%a(%a)" (path is_path_open) p1 (path is_path_open) p2
+
+let tree_of_path p = tree_of_path is_path_open p
+let path ppf p = path is_path_open ppf p
 
 (* Print a recursive annotation *)
 
 let print_label ppf l =
   if !print_labels && l <> "" || is_optional l then fprintf ppf "%s:" l
 
+(* ty must be repred *)
+let rec find_expansions acc ty =
+  match ty.desc with
+  | Tconstr (p, tyl, _abbrev) -> 
+      let acc = (p, tyl, ty) :: acc in
+      begin try
+	  find_expansions  acc (try_expand_once_opt !env_ref ty)
+      with
+      | Cannot_expand -> acc
+      end
+  | _ -> acc
+
+let compare_expansion (p1, tyl1, _) (p2, tyl2, _) =
+  match compare (List.length tyl1) (List.length tyl2) with
+  | 0 ->
+      let rec score_of_tree = function
+	| Oide_ident s -> 0, String.length s
+	| Oide_dot(p, s) -> 
+	    let (p, s) = score_of_tree p in
+	    p + 1, s
+	| Oide_apply(p1, p2) -> 
+	    let p1, s1 = score_of_tree p1 in
+	    let p2, s2 = score_of_tree p2 in
+	    p1 + p2 + 1, s1 + s2
+      in
+      let score_of_path p = score_of_tree (tree_of_path p) in
+      compare (score_of_path p1) (score_of_path p2)
+  | n -> n
+
+let rec find_min compare current = function
+  | [] -> current
+  | x::xs ->
+      match compare current x with
+      | -1 | 0 -> find_min compare current xs
+      | 1 -> find_min compare x xs
+      | _ -> assert false
+
+let heuristic_expand_constructor_type ty =
+  let expansions = find_expansions [] ty in
+  match expansions with
+  | [] -> None
+  | x::xs -> Some (find_min compare_expansion x xs)
+
 let rec tree_of_typexp sch ty =
   let ty = repr ty in
   let px = proxy ty in
     | Ttuple tyl ->
         Otyp_tuple (tree_of_typlist sch tyl)
     | Tconstr(p, tyl, abbrev) ->
-        Otyp_constr (tree_of_path p, tree_of_typlist sch tyl)
+	begin match heuristic_expand_constructor_type ty with
+	| Some (_, _, ty') when ty != ty' -> 
+	    tree_of_typexp sch ty'
+	| Some _ | None -> 
+	    Otyp_constr (tree_of_path p, tree_of_typlist sch tyl)
+	end
     | Tvariant row ->
         let row = row_repr row in
         let fields =

File typing/printtyp.mli

 open Types
 open Outcometree
 
+val under_env : Env.t -> ('a -> 'b) -> 'a -> 'b
+
 val longident: formatter -> Longident.t -> unit
 val ident: formatter -> Ident.t -> unit
 val tree_of_path: Path.t -> out_ident

File typing/typeclass.ml

   | Final_self_clash of (type_expr * type_expr) list
   | Mutability_mismatch of string * mutable_flag
 
-exception Error of Location.t * error
+exception Error of Env.t * Location.t * error
 
 
                        (**********************)
   let (id, virt) =
     try
       let (id, mut', virt', ty') = Vars.find lab !vars in
-      if mut' <> mut then raise (Error(loc, Mutability_mismatch(lab, mut)));
+      if mut' <> mut then raise (Error(Env.empty, loc, Mutability_mismatch(lab, mut)));
       Ctype.unify val_env (Ctype.instance ty) (Ctype.instance ty');
       (if not inh then Some id else None),
       (if virt' = Concrete then virt' else virt)
     with
       Ctype.Unify tr ->
-        raise (Error(loc, Field_type_mismatch("instance variable", lab, tr)))
+        raise (Error(val_env, loc, Field_type_mismatch("instance variable", lab, tr)))
     | Not_found -> None, virt
   in
   let (id, _, _, _) as result =
       with Ctype.Unify trace ->
         match trace with
           _::_::_::({desc = Tfield(n, _, _, _)}, _)::rem ->
-            raise(Error(loc, Field_type_mismatch ("method", n, rem)))
+            raise(Error(env, loc, Field_type_mismatch ("method", n, rem)))
         | _ ->
             assert false
       end;
       (cl_sig, concr_meths, warn_meths)
 
   | _ ->
-      raise(Error(loc, Structure_expected parent))
+      raise(Error(env, loc, Structure_expected parent))
 
 let virtual_method val_env meths self_type lab priv sty loc =
   let (_, ty') =
   in
   let ty = transl_simple_type val_env false sty in
   try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
-    raise(Error(loc, Field_type_mismatch ("method", lab, trace)))
+    raise(Error(val_env, loc, Field_type_mismatch ("method", lab, trace)))
 
 let delayed_meth_specs = ref []
 
   in
   let unif ty =
     try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
-      raise(Error(loc, Field_type_mismatch ("method", lab, trace)))
+      raise(Error(val_env, loc, Field_type_mismatch ("method", lab, trace)))
   in
   match sty.ptyp_desc, priv with
     Ptyp_poly ([],sty), Public ->
   let ty  = transl_simple_type val_env false sty in
   let ty' = transl_simple_type val_env false sty' in
   try Ctype.unify val_env ty ty' with Ctype.Unify trace ->
-    raise(Error(loc, Unconsistent_constraint trace))
+    raise(Error(val_env, loc, Unconsistent_constraint trace))
 
 let mkpat d = { ppat_desc = d; ppat_loc = Location.none }
 let make_method cl_num expr =
   begin try
     Ctype.unify env self_type dummy_obj
   with Ctype.Unify _ ->
-    raise(Error(sty.ptyp_loc, Pattern_type_clash self_type))
+    raise(Error(env, sty.ptyp_loc, Pattern_type_clash self_type))
   end;
 
   (* Class type fields *)
     Pcty_constr (lid, styl) ->
       let (path, decl) =
         try Env.lookup_cltype lid env with Not_found ->
-          raise(Error(scty.pcty_loc, Unbound_class_type lid))
+          raise(Error(env, scty.pcty_loc, Unbound_class_type lid))
       in
       if Path.same decl.clty_path unbound_class then
-        raise(Error(scty.pcty_loc, Unbound_class_type_2 lid));
+        raise(Error(env, scty.pcty_loc, Unbound_class_type_2 lid));
       let (params, clty) =
         Ctype.instance_class decl.clty_params decl.clty_type
       in
       if List.length params <> List.length styl then
-        raise(Error(scty.pcty_loc,
+        raise(Error(env, scty.pcty_loc,
                     Parameter_arity_mismatch (lid, List.length params,
                                                    List.length styl)));
       List.iter2
         (fun sty ty ->
            let ty' = transl_simple_type env false sty in
            try Ctype.unify env ty' ty with Ctype.Unify trace ->
-             raise(Error(sty.ptyp_loc, Parameter_mismatch trace)))
+             raise(Error(env, sty.ptyp_loc, Parameter_mismatch trace)))
         styl params;
       Tcty_constr (path, params, clty)
 
       if !Clflags.principal then Ctype.begin_def ();
       let exp =
         try type_exp val_env sexp with Ctype.Unify [(ty, _)] ->
-          raise(Error(loc, Make_nongen_seltype ty))
+          raise(Error(val_env, loc, Make_nongen_seltype ty))
       in
       if !Clflags.principal then begin
         Ctype.end_def ();
           end
       | _ -> assert false
       with Ctype.Unify trace ->
-        raise(Error(loc, Field_type_mismatch ("method", lab, trace)))
+        raise(Error(val_env, loc, Field_type_mismatch ("method", lab, trace)))
       end;
       let meth_expr = make_method cl_num expr in
       (* backup variables for Pexp_override *)
         try
           Typecore.type_let val_env rec_flag sdefs None
         with Ctype.Unify [(ty, _)] ->
-          raise(Error(loc, Make_nongen_seltype ty))
+          raise(Error(val_env, loc, Make_nongen_seltype ty))
       in
       let (vals, met_env, par_env) =
         List.fold_right
     else self_type in
   begin try Ctype.unify val_env public_self ty with
     Ctype.Unify _ ->
-      raise(Error(spat.ppat_loc, Pattern_type_clash public_self))
+      raise(Error(val_env, spat.ppat_loc, Pattern_type_clash public_self))
   end;
   let get_methods ty =
     (fst (Ctype.flatten_fields
         (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l)
         sign.cty_vars [] in
     if mets <> [] || vals <> [] then
-      raise(Error(loc, Virtual_class(true, mets, vals)));
+      raise(Error(val_env, loc, Virtual_class(true, mets, vals)));
     let self_methods =
       List.fold_right
         (fun (lab,kind,ty) rem ->
       Ctype.unify val_env private_self
         (Ctype.newty (Tobject(self_methods, ref None)));
       Ctype.unify val_env public_self self_type
-    with Ctype.Unify trace -> raise(Error(loc, Final_self_clash trace))
+    with Ctype.Unify trace -> raise(Error(val_env, loc, Final_self_clash trace))
     end;
   end;
 
     Pcl_constr (lid, styl) ->
       let (path, decl) =
         try Env.lookup_class lid val_env with Not_found ->
-          raise(Error(scl.pcl_loc, Unbound_class lid))
+          raise(Error(val_env, scl.pcl_loc, Unbound_class lid))
       in
       if Path.same decl.cty_path unbound_class then
-        raise(Error(scl.pcl_loc, Unbound_class_2 lid));
+        raise(Error(val_env, scl.pcl_loc, Unbound_class_2 lid));
       let tyl = List.map
           (fun sty -> transl_simple_type val_env false sty, sty.ptyp_loc)
           styl
       in
       let clty' = abbreviate_class_type path params clty in
       if List.length params <> List.length tyl then
-        raise(Error(scl.pcl_loc,
+        raise(Error(val_env, scl.pcl_loc,
                     Parameter_arity_mismatch (lid, List.length params,
                                                    List.length tyl)));
       List.iter2
         (fun (ty',loc) ty ->
            try Ctype.unify val_env ty' ty with Ctype.Unify trace ->
-             raise(Error(loc, Parameter_mismatch trace)))
+             raise(Error(val_env, loc, Parameter_mismatch trace)))
         tyl params;
       let cl =
         rc {cl_desc = Tclass_ident path;
               if ignore_labels && not (Btype.is_optional l) then begin
                 match sargs, more_sargs with
                   (l', sarg0)::_, _ ->
-                    raise(Error(sarg0.pexp_loc, Apply_wrong_label(l')))
+                    raise(Error(Env.empty, sarg0.pexp_loc, Apply_wrong_label(l')))
                 | _, (l', sarg0)::more_sargs ->
                     if l <> l' && l' <> "" then
-                      raise(Error(sarg0.pexp_loc, Apply_wrong_label l'))
+                      raise(Error(Env.empty, sarg0.pexp_loc, Apply_wrong_label l'))
                     else ([], more_sargs, Some(type_argument val_env sarg0 ty))
                 | _ ->
                     assert false
             match sargs @ more_sargs with
               (l, sarg0)::_ ->
                 if omitted <> [] then
-                  raise(Error(sarg0.pexp_loc, Apply_wrong_label l))
+                  raise(Error(Env.empty, sarg0.pexp_loc, Apply_wrong_label l))
                 else
-                  raise(Error(cl.cl_loc, Cannot_apply cl.cl_type))
+                  raise(Error(val_env, cl.cl_loc, Cannot_apply cl.cl_type))
             | [] ->
                 (List.rev args,
                  List.fold_left
         try
           Typecore.type_let val_env rec_flag sdefs None
         with Ctype.Unify [(ty, _)] ->
-          raise(Error(scl.pcl_loc, Make_nongen_seltype ty))
+          raise(Error(val_env, scl.pcl_loc, Make_nongen_seltype ty))
       in
       let (vals, met_env) =
         List.fold_right
 
       begin match Includeclass.class_types val_env cl.cl_type clty with
         []    -> ()
-      | error -> raise(Error(cl.cl_loc, Class_match_failure error))
+      | error -> raise(Error(val_env, cl.cl_loc, Class_match_failure error))
       end;
       let (vals, meths, concrs) = extract_constraints clty in
       rc {cl_desc = Tclass_constraint (cl, vals, meths, concrs);
       let params, loc = cl.pci_params in
       List.map (enter_type_variable true loc) params
     with Already_bound ->
-      raise(Error(snd cl.pci_params, Repeated_parameter))
+      raise(Error(Env.empty, snd cl.pci_params, Repeated_parameter))
   in
 
   (* Allow self coercions (only for class declarations) *)
     begin try
       List.iter2 (Ctype.unify env) obj_params obj_params'
     with Ctype.Unify _ ->
-      raise(Error(cl.pci_loc,
+      raise(Error(env, cl.pci_loc,
             Bad_parameters (obj_id, constr,
                             Ctype.newconstr (Path.Pident obj_id)
                                             obj_params')))
     begin try
       Ctype.unify env ty constr
     with Ctype.Unify _ ->
-      raise(Error(cl.pci_loc,
+      raise(Error(env, cl.pci_loc,
         Abbrev_type_clash (constr, ty, Ctype.expand_head env constr)))
     end
   end;
     begin try
       List.iter2 (Ctype.unify env) cl_params cl_params'
     with Ctype.Unify _ ->
-      raise(Error(cl.pci_loc,
+      raise(Error(env, cl.pci_loc,
             Bad_parameters (cl_id,
                             Ctype.newconstr (Path.Pident cl_id)
                                             cl_params,
       Ctype.unify env ty cl_ty
     with Ctype.Unify _ ->
       let constr = Ctype.newconstr (Path.Pident cl_id) params in
-      raise(Error(cl.pci_loc, Abbrev_type_clash (constr, ty, cl_ty)))
+      raise(Error(env, cl.pci_loc, Abbrev_type_clash (constr, ty, cl_ty)))
     end
   end;
 
       (constructor_type constr obj_type)
       (Ctype.instance constr_type)
   with Ctype.Unify trace ->
-    raise(Error(cl.pci_loc,
+    raise(Error(env, cl.pci_loc,
                 Constructor_type_mismatch (cl.pci_name, trace)))
   end;
 
         (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l)
         sign.cty_vars [] in
     if mets <> []  || vals <> [] then
-      raise(Error(cl.pci_loc, Virtual_class(true, mets, vals)));
+      raise(Error(env, cl.pci_loc, Virtual_class(true, mets, vals)));
   end;
 
   (* Misc. *)
 
   begin try Ctype.collapse_conj_params env clty.cty_params
   with Ctype.Unify trace ->
-    raise(Error(cl.pci_loc, Non_collapsable_conjunction (id, clty, trace)))
+    raise(Error(env, cl.pci_loc, Non_collapsable_conjunction (id, clty, trace)))
   end;
 
   List.iter Ctype.generalize clty.cty_params;
   end;
 
   if not (closed_class clty) then
-    raise(Error(cl.pci_loc, Non_generalizable_class (id, clty)));
+    raise(Error(env, cl.pci_loc, Non_generalizable_class (id, clty)));
 
   begin match
     Ctype.closed_class clty.cty_params
         then function ppf -> Printtyp.class_declaration id ppf clty
         else function ppf -> Printtyp.cltype_declaration id ppf cltydef
       in
-      raise(Error(cl.pci_loc, Unbound_type_var(printer, reason)))
+      raise(Error(env, cl.pci_loc, Unbound_type_var(printer, reason)))
   end;
 
   (id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
       in
       begin try Ctype.subtype env cl_ty obj_ty ()
       with Ctype.Subtype (tr1, tr2) ->
-        raise(Typecore.Error(loc, Typecore.Not_subtype(tr1, tr2)))
+        raise(Typecore.Error(env, loc, Typecore.Not_subtype(tr1, tr2)))
       end;
       if not (Ctype.opened_object cl_ty) then
-        raise(Error(loc, Cannot_coerce_self obj_ty))
+        raise(Error(env, loc, Cannot_coerce_self obj_ty))
   end;
   (id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
    arity, pub_meths, expr)
       fprintf ppf
         "@[The instance variable is %s;@ it cannot be redefined as %s@]"
         mut1 mut2
+
+let report_error env ppf =
+  Printtyp.under_env env (report_error ppf)

File typing/typeclass.mli

   | Final_self_clash of (type_expr * type_expr) list
   | Mutability_mismatch of string * mutable_flag
 
-exception Error of Location.t * error
+exception Error of Env.t * Location.t * error
 
-val report_error : formatter -> error -> unit
+val report_error : Env.t -> formatter -> error -> unit

File typing/typecore.ml

   | Incoherent_label_order
   | Less_general of string * (type_expr * type_expr) list
 
-exception Error of Location.t * error
+exception Error of Env.t * Location.t * error
 
 (* Forward declaration, to be filled in by Typemod.type_module *)
 
     unify env pat.pat_type expected_ty
   with
     Unify trace ->
-      raise(Error(pat.pat_loc, Pattern_type_clash(trace)))
+      raise(Error(env, pat.pat_loc, Pattern_type_clash(trace)))
   | Tags(l1,l2) ->
-      raise(Typetexp.Error(pat.pat_loc, Typetexp.Variant_tags (l1, l2)))
+      raise(Typetexp.Error(env, pat.pat_loc, Typetexp.Variant_tags (l1, l2)))
 
 (* make all Reither present in open variants *)
 let finalize_variant pat =
 
 let enter_variable loc name ty =
   if List.exists (fun (id, _, _) -> Ident.name id = name) !pattern_variables
-  then raise(Error(loc, Multiply_bound_variable name));
+  then raise(Error(Env.empty, loc, Multiply_bound_variable name));
   let id = Ident.create name in
   pattern_variables := (id, ty, loc) :: !pattern_variables;
   begin match !pattern_scope with
               unify env t1 t2
             with
             | Unify trace ->
-                raise(Error(loc, Pattern_type_clash(trace)))
+                raise(Error(env, loc, Pattern_type_clash(trace)))
             end ;
           (x2,x1)::unify_vars rem1 rem2
           end
       | [],[] -> []
-      | (x,_,_)::_, [] -> raise (Error (loc, Orpat_vars x))
-      | [],(x,_,_)::_  -> raise (Error (loc, Orpat_vars x))
+      | (x,_,_)::_, [] -> raise (Error (env, loc, Orpat_vars x))
+      | [],(x,_,_)::_  -> raise (Error (env, loc, Orpat_vars x))
       | (x,_,_)::_, (y,_,_)::_ ->
           let min_var =
             if Ident.name x < Ident.name y then x
             else y in
-          raise (Error (loc, Orpat_vars min_var)) in
+          raise (Error (env, loc, Orpat_vars min_var)) in
   unify_vars p1_vs p2_vs
 
 let rec build_as_type env p =
   let path, decl =
     try Env.lookup_type lid env
     with Not_found ->
-      raise(Typetexp.Error(loc, Typetexp.Unbound_type_constructor lid))
+      raise(Typetexp.Error(env, loc, Typetexp.Unbound_type_constructor lid))
   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, Not_a_variant_type lid))
+    | _ -> raise(Error(env, loc, Not_a_variant_type lid))
   in
   let pats, fields =
     List.fold_left
       pats
   in
   match pats with
-    [] -> raise(Error(loc, Not_a_variant_type lid))
+    [] -> raise(Error(env, loc, Not_a_variant_type lid))
   | pat :: pats ->
       let r =
         List.fold_left
         try
           Env.lookup_constructor lid env
         with Not_found ->
-          raise(Error(sp.ppat_loc, Unbound_constructor lid)) in
+          raise(Error(env, sp.ppat_loc, Unbound_constructor lid)) in
       let sargs =
         match sarg with
           None -> []
             replicate_list sp constr.cstr_arity
         | Some sp -> [sp] in
       if List.length sargs <> constr.cstr_arity then
-        raise(Error(sp.ppat_loc, Constructor_arity_mismatch(lid,
+        raise(Error(env, sp.ppat_loc, Constructor_arity_mismatch(lid,
                                      constr.cstr_arity, List.length sargs)));
       let args = List.map (type_pat env) sargs in
       let (ty_args, ty_res) = instance_constructor constr in
         [] -> ()
       | (lid, sarg) :: remainder ->
           if List.mem_assoc lid remainder
-          then raise(Error(sp.ppat_loc, Label_multiply_defined lid))
+          then raise(Error(env, sp.ppat_loc, Label_multiply_defined lid))
           else check_duplicates remainder in
       check_duplicates lid_sp_list;
       let ty = newvar() in
           try
             Env.lookup_label lid env
           with Not_found ->
-            raise(Error(sp.ppat_loc, Unbound_label lid)) in
+            raise(Error(env, sp.ppat_loc, Unbound_label lid)) in
         begin_def ();
         let (vars, ty_arg, ty_res) = instance_label false label in
         if vars = [] then end_def ();
         begin try
           unify env ty_res ty
         with Unify trace ->
-          raise(Error(sp.ppat_loc, Label_mismatch(lid, trace)))
+          raise(Error(env, sp.ppat_loc, Label_mismatch(lid, trace)))
         end;
         let arg = type_pat env sarg in
         unify_pat env arg ty_arg;
             let tv = expand_head env tv in
             tv.desc <> Tvar || tv.level <> generic_level in
           if List.exists instantiated vars then
-            raise (Error(sp.ppat_loc, Polymorphic_label lid))
+            raise (Error(env, sp.ppat_loc, Polymorphic_label lid))
         end;
         (label, arg)
       in
   let ty_arrow gty ty = newty (Tarrow ("", instance gty, ty, Cok)) in
 
   let bad_conversion fmt i c =
-    raise (Error (loc, Bad_conversion (fmt, i, c))) in
+    raise (Error (Env.empty, loc, Bad_conversion (fmt, i, c))) in
   let incomplete_format fmt =
-    raise (Error (loc, Incomplete_format fmt)) in
+    raise (Error (Env.empty, loc, Incomplete_format fmt)) in
 
   let range_closing_index fmt i =
 
       and ty1 = approx_ty_opt sty1
       and ty2 = approx_ty_opt sty2 in
       begin try unify env ty ty1 with Unify trace ->
-        raise(Error(sexp.pexp_loc, Expr_type_clash trace))
+        raise(Error(env, sexp.pexp_loc, Expr_type_clash trace))
       end;
       if sty2 = None then ty1 else ty2
   | _ -> newvar ()
   if List.length vars = List.length vars' then () else
   let ty = newgenty (Tpoly(repr exp.exp_type, vars'))
   and ty_expected = repr ty_expected in
-  raise (Error (exp.exp_loc,
+  raise (Error (exp.exp_env, exp.exp_loc,
                 Less_general(kind, [ty, ty; ty_expected, ty_expected])))
 
 (* Check that a type is not a function *)
     unify env exp.exp_type expected_ty
   with
     Unify trace ->
-      raise(Error(exp.exp_loc, Expr_type_clash(trace)))
+      raise(Error(env, exp.exp_loc, Expr_type_clash(trace)))
   | Tags(l1,l2) ->
-      raise(Typetexp.Error(exp.exp_loc, Typetexp.Variant_tags (l1, l2)))
+      raise(Typetexp.Error(env, exp.exp_loc, Typetexp.Variant_tags (l1, l2)))
 
 let rec type_exp env sexp =
   match sexp.pexp_desc with
                 in
                 Texp_ident(path, desc)
             | Val_unbound ->
-                raise(Error(sexp.pexp_loc, Masked_instance_variable lid))
+                raise(Error(env, sexp.pexp_loc, Masked_instance_variable lid))
             | _ ->
                 Texp_ident(path, desc)
             end;
           exp_type = instance desc.val_type;
           exp_env = env }
       with Not_found ->
-        raise(Error(sexp.pexp_loc, Unbound_value lid))
+        raise(Error(env, sexp.pexp_loc, Unbound_value lid))
       end
   | Pexp_constant cst ->
       re {
           try
             Env.lookup_label lid env
           with Not_found ->
-            raise(Error(sexp.pexp_loc, Unbound_label lid)) in
+            raise(Error(env, sexp.pexp_loc, Unbound_label lid)) in
         begin_def ();
         if !Clflags.principal then begin_def ();
         let (vars, ty_arg, ty_res) = instance_label true label in
         begin try
           unify env (instance ty_res) ty
         with Unify trace ->
-          raise(Error(sexp.pexp_loc, Label_mismatch(lid, trace)))
+          raise(Error(env, sexp.pexp_loc, Label_mismatch(lid, trace)))
         end;
         let arg = type_argument env sarg ty_arg in
         end_def ();
         check_univars env "field value" arg label.lbl_arg vars;
         num_fields := Array.length label.lbl_all;
         if label.lbl_private = Private then
-          raise(Error(sexp.pexp_loc, Private_type ty));
+          raise(Error(env, sexp.pexp_loc, Private_type ty));
         (label, {arg with exp_type = instance arg.exp_type}) in
       let lbl_exp_list = type_label_a_list type_label_exp lid_sexp_list in
       let rec check_duplicates seen_pos lid_sexp lbl_exp =
         match (lid_sexp, lbl_exp) with
           ((lid, _) :: rem1, (lbl, _) :: rem2) ->
             if List.mem lbl.lbl_pos seen_pos
-            then raise(Error(sexp.pexp_loc, Label_multiply_defined lid))
+            then raise(Error(env, sexp.pexp_loc, Label_multiply_defined lid))
             else check_duplicates (lbl.lbl_pos :: seen_pos) rem1 rem2
         | (_, _) -> () in
       check_duplicates [] lid_sexp_list lbl_exp_list;
               else lbl :: missing_labels (n + 1) rem
         in
         let missing = missing_labels 0 label_names in
-        raise(Error(sexp.pexp_loc, Label_missing missing))
+        raise(Error(env, sexp.pexp_loc, Label_missing missing))
       end
       else if opt_sexp <> None && List.length lid_sexp_list = !num_fields then
         Location.prerr_warning sexp.pexp_loc Warnings.Useless_record_with;
         try
           Env.lookup_label lid env
         with Not_found ->
-          raise(Error(sexp.pexp_loc, Unbound_label lid)) in
+          raise(Error(env, sexp.pexp_loc, Unbound_label lid)) in
       let (_, ty_arg, ty_res) = instance_label false label in
       unify_exp env arg ty_res;
       re {
         try
           Env.lookup_label lid env
         with Not_found ->
-          raise(Error(sexp.pexp_loc, Unbound_label lid)) in
+          raise(Error(env, sexp.pexp_loc, Unbound_label lid)) in
       if label.lbl_mut = Immutable then
-        raise(Error(sexp.pexp_loc, Label_not_mutable lid));
+        raise(Error(env, sexp.pexp_loc, Label_not_mutable lid));
       begin_def ();
       let (vars, ty_arg, ty_res) = instance_label true label in
       unify_exp env record ty_res;
         generalize_expansive env newval.exp_type;
       check_univars env "field value" newval label.lbl_arg vars;
       if label.lbl_private = Private then
-        raise(Error(sexp.pexp_loc, Private_label(lid, ty_res)));
+        raise(Error(env, sexp.pexp_loc, Private_label(lid, ty_res)));
       re {
         exp_desc = Texp_setfield(record, label, newval);
         exp_loc = sexp.pexp_loc;
                       (Warnings.Not_principal "this ground coercion");
                 with Subtype (tr1, tr2) ->
                   (* prerr_endline "coercion failed"; *)
-                  raise(Error(sexp.pexp_loc, Not_subtype(tr1, tr2)))
+                  raise(Error(env, sexp.pexp_loc, Not_subtype(tr1, tr2)))
                 end;
             | _ ->
                 let ty, b = enlarge_type env ty' in
                 force ();
                 begin try Ctype.unify env arg.exp_type ty with Unify trace ->
-                  raise(Error(sarg.pexp_loc,
+                  raise(Error(env, sarg.pexp_loc,
                         Coercion_failure(ty', full_expand env ty', trace, b)))
                 end
             end;
               let force'' = subtype env ty ty' in
               force (); force' (); force'' ()
             with Subtype (tr1, tr2) ->
-              raise(Error(sexp.pexp_loc, Not_subtype(tr1, tr2)))
+              raise(Error(env, sexp.pexp_loc, Not_subtype(tr1, tr2)))
             end;
             (type_expect env sarg ty, ty')
       in
           | Texp_ident(path, {val_kind = Val_anc (methods, cl_num)}) ->
               let method_id =
                 begin try List.assoc met methods with Not_found ->
-                  raise(Error(e.pexp_loc, Undefined_inherited_method met))
+                  raise(Error(env, e.pexp_loc, Undefined_inherited_method met))
                 end
               in
               begin match
             exp_type = typ;
             exp_env = env }
       with Unify _ ->
-        raise(Error(e.pexp_loc, Undefined_method (obj.exp_type, met)))
+        raise(Error(env, e.pexp_loc, Undefined_method (obj.exp_type, met)))
       end
   | Pexp_new cl ->
       let (cl_path, cl_decl) =
         try Env.lookup_class cl env with Not_found ->
-          raise(Error(sexp.pexp_loc, Unbound_class cl))
+          raise(Error(env, sexp.pexp_loc, Unbound_class cl))
       in
         begin match cl_decl.cty_new with
           None ->
-            raise(Error(sexp.pexp_loc, Virtual_class cl))
+            raise(Error(env, sexp.pexp_loc, Virtual_class cl))
         | Some ty ->
             re {
               exp_desc = Texp_new (cl_path, cl_decl);
               exp_type = instance Predef.type_unit;
               exp_env = env }
         | Val_ivar _ ->
-            raise(Error(sexp.pexp_loc, Instance_variable_not_mutable lab))
+            raise(Error(env, sexp.pexp_loc, Instance_variable_not_mutable lab))
         | _ ->
-            raise(Error(sexp.pexp_loc, Unbound_instance_variable lab))
+            raise(Error(env, sexp.pexp_loc, Unbound_instance_variable lab))
       with
         Not_found ->
-          raise(Error(sexp.pexp_loc, Unbound_instance_variable lab))
+          raise(Error(env, sexp.pexp_loc, Unbound_instance_variable lab))
       end
   | Pexp_override lst ->
       let _ =
        List.fold_right
         (fun (lab, _) l ->
            if List.exists ((=) lab) l then
-             raise(Error(sexp.pexp_loc,
+             raise(Error(env, sexp.pexp_loc,
                          Value_multiply_overridden lab));
            lab::l)
         lst
           Env.lookup_value (Longident.Lident "selfpat-*") env,
           Env.lookup_value (Longident.Lident "self-*") env
         with Not_found ->
-          raise(Error(sexp.pexp_loc, Outside_class))
+          raise(Error(env, sexp.pexp_loc, Outside_class))
       with
         (_, {val_type = self_ty; val_kind = Val_self (_, vars, _, _)}),
         (path_self, _) ->
               (Path.Pident id, type_expect env snewval (instance ty))
             with
               Not_found ->
-                raise(Error(sexp.pexp_loc, Unbound_instance_variable lab))
+                raise(Error(env, sexp.pexp_loc, Unbound_instance_variable lab))
             end
           in
           let modifs = List.map type_override lst in
       begin try
         Ctype.unify new_env body.exp_type ty
       with Unify _ ->
-        raise(Error(sexp.pexp_loc, Scoping_let_module(name, body.exp_type)))
+        raise(Error(new_env, sexp.pexp_loc, Scoping_let_module(name, body.exp_type)))
       end;
       re {
         exp_desc = Texp_letmodule(id, modl, body);
               match ty_res.desc with
                 Tarrow _ ->
                   if (!Clflags.classic || not (has_label l1 ty_fun)) then
-                    raise(Error(sarg1.pexp_loc, Apply_wrong_label(l1, ty_res)))
+                    raise(Error(env, sarg1.pexp_loc, Apply_wrong_label(l1, ty_res)))
                   else
-                    raise(Error(funct.exp_loc, Incoherent_label_order))
+                    raise(Error(env, funct.exp_loc, Incoherent_label_order))
               | _ ->
-                  raise(Error(funct.exp_loc, Apply_non_function
+                  raise(Error(env, funct.exp_loc, Apply_non_function
                                 (expand_head env funct.exp_type)))
         in
         let optional = if is_optional l1 then Optional else Required in
             (* In classic mode, omitted = [] *)
             match sargs, more_sargs with
               (l', sarg0) :: _, _ ->
-                raise(Error(sarg0.pexp_loc, Apply_wrong_label(l', ty_old)))
+                raise(Error(env, sarg0.pexp_loc, Apply_wrong_label(l', ty_old)))
             | _, (l', sarg0) :: more_sargs ->
                 if l <> l' && l' <> "" then
-                  raise(Error(sarg0.pexp_loc, Apply_wrong_label(l', ty_fun')))
+                  raise(Error(env, sarg0.pexp_loc, Apply_wrong_label(l', ty_fun')))
                 else
                   ([], more_sargs, Some (fun () -> type_argument env sarg0 ty))
             | _ ->
     | _ ->
         match sargs with
           (l, sarg0) :: _ when ignore_labels ->
-            raise(Error(sarg0.pexp_loc, Apply_wrong_label(l, ty_old)))
+            raise(Error(env, sarg0.pexp_loc, Apply_wrong_label(l, ty_old)))
         | _ ->
             type_unknown_args args omitted (instance ty_fun)
               (sargs @ more_sargs)
     try
       Env.lookup_constructor lid env
     with Not_found ->
-      raise(Error(loc, Unbound_constructor lid)) in
+      raise(Error(env, loc, Unbound_constructor lid)) in
   let sargs =
     match sarg with
       None -> []
     | Some {pexp_desc = Pexp_tuple sel} when constr.cstr_arity > 1 -> sel
     | Some se -> [se] in
   if List.length sargs <> constr.cstr_arity then
-    raise(Error(loc, Constructor_arity_mismatch
+    raise(Error(env, loc, Constructor_arity_mismatch
                   (lid, constr.cstr_arity, List.length sargs)));
   if !Clflags.principal then begin_def ();
   let (ty_args, ty_res) = instance_constructor constr in
   unify_exp env texp ty_expected;
   let args = List.map2 (type_argument env) sargs ty_args in
   if constr.cstr_private = Private then
-    raise(Error(loc, Private_type ty_res));
+    raise(Error(env, loc, Private_type ty_res));
   { texp with exp_desc = Texp_construct(constr, args) }
 
 (* Typing of an expression with an expected type.
         with Unify _ ->
           match expand_head env ty_expected with
             {desc = Tarrow _} as ty ->
-              raise(Error(sexp.pexp_loc, Abstract_wrong_label(l, ty)))
+              raise(Error(env, sexp.pexp_loc, Abstract_wrong_label(l, ty)))
           | _ ->
-              raise(Error(loc,
+              raise(Error(env, loc,
                           Too_many_arguments (in_function <> None, ty_fun)))
       in
       let ty_arg =
       report_unification_error ppf trace
         (fun ppf -> fprintf ppf "This %s has type" kind)
         (fun ppf -> fprintf ppf "which is less general than")
+
+let report_error env ppf = 
+  Printtyp.under_env env (report_error ppf)
+

File typing/typecore.mli

   | Incoherent_label_order
   | Less_general of string * (type_expr * type_expr) list
 
-exception Error of Location.t * error
+exception Error of Env.t * Location.t * error
 
-val report_error: formatter -> error -> unit
+val report_error: Env.t -> formatter -> error -> unit
 
 (* Forward declaration, to be filled in by Typemod.type_module *)
 val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref

File typing/typedecl.ml

   | Bad_fixed_type of string
   | Unbound_type_var_exc of type_expr * type_expr
 
-exception Error of Location.t * error
+exception Error of Env.t * Location.t * error
 
 (* Enter all declared types in the environment as abstract types *)
 
       let params = List.map (fun _ -> Ctype.newvar ()) decl.type_params in
       try Ctype.unify env (Ctype.newconstr path params) ty
       with Ctype.Unify trace ->
-        raise (Error(loc, Type_clash trace))
+        raise (Error(env, loc, Type_clash trace))
 
 (* Determine if a type is (an abbreviation for) the type "float" *)
 (* We use the Ctype.expand_head_opt version of expand_head to get access
     | Tobject (ty, _) ->
         snd (Ctype.flatten_fields ty)
     | _ ->
-        raise (Error (loc, Bad_fixed_type "is not an object or variant"))
+        raise (Error (env, loc, Bad_fixed_type "is not an object or variant"))
   in
   if rv.desc <> Tvar then
-    raise (Error (loc, Bad_fixed_type "has no row variable"));
+    raise (Error (env, loc, Bad_fixed_type "has no row variable"));
   rv.desc <- Tconstr (p, decl.type_params, ref Mnil)
 
 (* Translate one type declaration *)
   let params =
     try List.map (enter_type_variable true sdecl.ptype_loc) sdecl.ptype_params
     with Already_bound ->
-      raise(Error(sdecl.ptype_loc, Repeated_parameter))
+      raise(Error(env, sdecl.ptype_loc, Repeated_parameter))
   in
   let cstrs = List.map
       (fun (sty, sty', loc) ->
             List.iter
               (fun (name, args, loc) ->
                 if StringSet.mem name !all_constrs then
-                  raise(Error(sdecl.ptype_loc, Duplicate_constructor name));
+                  raise(Error(env, sdecl.ptype_loc, Duplicate_constructor name));
                 all_constrs := StringSet.add name !all_constrs)
               cstrs;
             if List.length (List.filter (fun (_, args, _) -> args <> []) cstrs)
                > (Config.max_tag + 1) then
-              raise(Error(sdecl.ptype_loc, Too_many_constructors));
+              raise(Error(env, sdecl.ptype_loc, Too_many_constructors));
             Type_variant
               (List.map
                  (fun (name, args, loc) ->
             List.iter
               (fun (name, mut, arg, loc) ->
                 if StringSet.mem name !all_labels then
-                  raise(Error(sdecl.ptype_loc, Duplicate_label name));
+                  raise(Error(env, sdecl.ptype_loc, Duplicate_label name));
                 all_labels := StringSet.add name !all_labels)
               lbls;
             let lbls' =
             let ty =
               transl_simple_type env no_row sty in
             if Ctype.cyclic_abbrev env id ty then
-              raise(Error(sdecl.ptype_loc, Recursive_abbrev name));
+              raise(Error(env, sdecl.ptype_loc, Recursive_abbrev name));
             Some ty
         end;
       type_variance = List.map (fun _ -> true, true, true) params;
   List.iter
     (fun (ty, ty', loc) ->
       try Ctype.unify env ty ty' with Ctype.Unify tr ->
-        raise(Error(loc, Unconsistent_constraint tr)))
+        raise(Error(env, loc, Unconsistent_constraint tr)))
     cstrs;
   Ctype.end_def ();
   if is_fixed_type sdecl then begin
       let ty' = Ctype.newconstr path args' in
       begin try Ctype.enforce_constraints env ty'
       with Ctype.Unify _ -> assert false
-      | Not_found -> raise (Error(loc, Unavailable_type_constructor path))
+      | Not_found -> raise (Error(env, loc, Unavailable_type_constructor path))
       end;
       if not (Ctype.matches env ty ty') then
-        raise (Error(loc, Constraint_failed (ty, ty')));
+        raise (Error(env, loc, Constraint_failed (ty, ty')));
       List.iter (check_constraints_rec env loc visited) args
   | Tpoly (ty, tl) ->
       let _, ty = Ctype.instance_poly false tl ty in
                 (Subst.type_declaration (Subst.add_type id path Subst.identity)
                                         decl)
             then ()
-            else raise(Error(sdecl.ptype_loc, Definition_mismatch ty))
+            else raise(Error(env, sdecl.ptype_loc, Definition_mismatch ty))
           with Not_found ->
-            raise(Error(sdecl.ptype_loc, Unavailable_type_constructor path))
+            raise(Error(env, sdecl.ptype_loc, Unavailable_type_constructor path))
           end
-      | _ -> raise(Error(sdecl.ptype_loc, Definition_mismatch ty))
+      | _ -> raise(Error(env, sdecl.ptype_loc, Definition_mismatch ty))
       end
   | _ -> ()
 
       | Tconstr(path', args', _) ->
           if Path.same path path' then begin
             if not (Ctype.equal env false args args') then
-              raise (Error(loc,
+              raise (Error(env, loc,
                      Parameters_differ(cpath, ty, Ctype.newconstr path args)))
           end
           (* Attempt to expand a type abbreviation if:
               begin
                 try List.iter2 (Ctype.unify env) params args'
                 with Ctype.Unify _ ->
-                  raise (Error(loc, Constraint_failed
+                  raise (Error(env, loc, Constraint_failed
                                  (ty, Ctype.newconstr path' params0)));
               end;
               check_regular path' args (path' :: prev_exp) body
       begin try
         Ctype.correct_abbrev env path decl.type_params body
       with Ctype.Recursive_abbrev ->
-        raise(Error(loc, Recursive_abbrev (Path.name path)))
-      | Ctype.Unify trace -> raise(Error(loc, Type_clash trace))
+        raise(Error(env, loc, Recursive_abbrev (Path.name path)))
+      | Ctype.Unify trace -> raise(Error(env, loc, Type_clash trace))
       end;
       (* Check that recursion is regular *)
       if decl.type_params = [] then () else
     (fun (ty, c1, n1, t1) (_, c2, n2, t2) ->
       if !c1 && not !c2 || !n1 && not !n2
       (* || !t1 && not !t2 && decl.type_kind = Type_abstract *)
-      then raise (Error(loc,
+      then raise (Error(env, loc,
                         if not (!c2 || !n2) then Unbound_type_var (ty, decl)
                         else Bad_variance (0, (!c1,!n1), (!c2,!n2)))))
     tvl1 tvl2;
     (fun (_, co, cn, ct) (c, n) ->
       incr pos;
       if !co && not c || !cn && not n
-      then raise (Error(loc, Bad_variance (!pos, (!co,!cn), (c,n))));
+      then raise (Error(env, loc, Bad_variance (!pos, (!co,!cn), (c,n))));
       if decl.type_private = Private then (c,n,n) else
       let ct = if decl.type_kind = Type_abstract then ct else cn in
       (!co, !cn, !ct))
   List.iter2
     (fun (_, sdecl) (id, decl) ->
        match Ctype.closed_type_decl decl with
-         Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl)))
+         Some ty -> raise(Error(newenv, sdecl.ptype_loc, Unbound_type_var(ty,decl)))
        | None   -> ())
     name_sdecl_list decls;
   (* Check re-exportation *)
   let ty = transl_simple_type env true sty in
   match Ctype.free_variables ty with
   | []      -> ty
-  | tv :: _ -> raise (Error (sty.ptyp_loc, Unbound_type_var_exc (tv, ty)))
+  | tv :: _ -> raise (Error (env, sty.ptyp_loc, Unbound_type_var_exc (tv, ty)))
 
 let transl_exception env excdecl =
   reset_type_variables();
     try
       Env.lookup_constructor lid env
     with Not_found ->
-      raise(Error(loc, Unbound_exception lid)) in
+      raise(Error(env, loc, Unbound_exception lid)) in
   match cdescr.cstr_tag with
     Cstr_exception path -> (path, cdescr.cstr_args)
-  | _ -> raise(Error(loc, Not_an_exception lid))
+  | _ -> raise(Error(env, loc, Not_an_exception lid))
 
 (* Translate a value declaration *)
 let transl_value_decl env valdecl =
   | decl ->
       let arity = Ctype.arity ty in
       if arity = 0 then
-        raise(Error(valdecl.pval_type.ptyp_loc, Null_arity_external));
+        raise(Error(env, valdecl.pval_type.ptyp_loc, Null_arity_external));
       let prim = Primitive.parse_declaration arity decl in
       if !Clflags.native_code
       && prim.prim_arity > 5
       && prim.prim_native_name = ""
-      then raise(Error(valdecl.pval_type.ptyp_loc, Missing_native_external));
+      then raise(Error(env, valdecl.pval_type.ptyp_loc, Missing_native_external));
       { val_type = ty; val_kind = Val_prim prim }
 
 (* Translate a "with" constraint -- much simplified version of
     try
       List.map (enter_type_variable true sdecl.ptype_loc) sdecl.ptype_params
     with Already_bound ->
-      raise(Error(sdecl.ptype_loc, Repeated_parameter)) in
+      raise(Error(env, sdecl.ptype_loc, Repeated_parameter)) in
   List.iter
     (function (ty, ty', loc) ->
        try
          Ctype.unify env (transl_simple_type env false ty)
                          (transl_simple_type env false ty')
        with Ctype.Unify tr ->
-         raise(Error(loc, Unconsistent_constraint tr)))
+         raise(Error(env,loc, Unconsistent_constraint tr)))
     sdecl.ptype_cstrs;
   let no_row = not (is_fixed_type sdecl) in
   let decl =
   | Some p -> set_fixed_row env sdecl.ptype_loc p decl
   end;
   begin match Ctype.closed_type_decl decl with None -> ()
-  | Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl)))
+  | Some ty -> raise(Error(env,sdecl.ptype_loc, Unbound_type_var(ty,decl)))
   end;
   let decl = name_recursion sdecl id decl in
   let decl =
       fprintf ppf "The definition of type %a@ is unavailable" Printtyp.path p
   | Bad_fixed_type r ->
       fprintf ppf "This fixed type %s" r
+
+let report_error env ppf =
+  Printtyp.under_env env (report_error ppf)

File typing/typedecl.mli

   | Bad_fixed_type of string
   | Unbound_type_var_exc of type_expr * type_expr
 
-exception Error of Location.t * error
+exception Error of Env.t * Location.t * error
 
-val report_error: formatter -> error -> unit
+val report_error: Env.t -> formatter -> error -> unit

File typing/typemod.ml

   | Implementation_is_required of string
   | Interface_not_compiled of string
 
-exception Error of Location.t * error
+exception Error of Env.t * Location.t * error
 
 (* Extract a signature from a module type *)
 
 let extract_sig env loc mty =
   match Mtype.scrape env mty with
     Tmty_signature sg -> sg
-  | _ -> raise(Error(loc, Signature_expected))
+  | _ -> raise(Error(env, loc, Signature_expected))
 
 let extract_sig_open env loc mty =
   match Mtype.scrape env mty with
     Tmty_signature sg -> sg
-  | _ -> raise(Error(loc, Structure_expected mty))
+  | _ -> raise(Error(env, loc, Structure_expected mty))
 
 (* Lookup the type of a module path *)
 
   try
     Env.lookup_module lid env
   with Not_found ->
-    raise(Error(loc, Unbound_module lid))
+    raise(Error(env, loc, Unbound_module lid))
 
 (* Record a module type *)
 let rm node =
   let rec merge env sg namelist row_id =
     match (sg, namelist, constr) with
       ([], _, _) ->
-        raise(Error(loc, With_no_component lid))
+        raise(Error(env, loc, With_no_component lid))
     | (Tsig_type(id, decl, rs) :: rem, [s],
        Pwith_type ({ptype_kind = Ptype_abstract} as sdecl))
       when Ident.name id = s && Typedecl.is_fixed_type sdecl ->
         item :: merge (Env.add_item item env) rem namelist row_id in
   try
     merge initial_env sg (Longident.flatten lid) None
-  with Includemod.Error explanation ->
-    raise(Error(loc, With_mismatch(lid, explanation)))
+  with Includemod.Error (env, explanation) ->
+    raise(Error(env, loc, With_mismatch(lid, explanation)))
 
 (* Add recursion flags on declarations arising from a mutually recursive
    block. *)
         let (path, info) = Env.lookup_modtype lid env in
         Tmty_ident path
       with Not_found ->
-        raise(Error(smty.pmty_loc, Unbound_modtype lid))
+        raise(Error(env, smty.pmty_loc, Unbound_modtype lid))
       end
   | Pmty_signature ssg ->
       Tmty_signature(approx_sig env ssg)
 
 let check cl loc set_ref name =
   if StringSet.mem name !set_ref
-  then raise(Error(loc, Repeated_name(cl, name)))
+  then raise(Error(Env.empty, loc, Repeated_name(cl, name)))
   else set_ref := StringSet.add name !set_ref
 
 let check_sig_item type_names module_names modtype_names loc = function
         let (path, info) = Env.lookup_modtype lid env in
         Tmty_ident path
       with Not_found ->
-        raise(Error(smty.pmty_loc, Unbound_modtype lid))
+        raise(Error(env, smty.pmty_loc, Unbound_modtype lid))
       end
   | Pmty_signature ssg ->
       Tmty_signature(transl_signature env ssg)
       List.iter
         (fun (pat, exp) ->
           if not (Ctype.closed_schema exp.exp_type) then
-            raise(Error(exp.exp_loc, Non_generalizable exp.exp_type)))
+            raise(Error(env, exp.exp_loc, Non_generalizable exp.exp_type)))
         pat_exp_list
   | Tstr_module(id, md) ->
       if not (closed_modtype md.mod_type) then
-        raise(Error(md.mod_loc, Non_generalizable_module md.mod_type))
+        raise(Error(env, md.mod_loc, Non_generalizable_module md.mod_type))
   | _ -> ()
 
 let check_nongen_schemes env str =
         let coercion =
           try
             Includemod.modtypes env mty_actual' mty_decl'
-          with Includemod.Error msg ->
-            raise(Error(modl.mod_loc, Not_included msg)) in
+          with Includemod.Error (env, msg) ->
+            raise(Error(env, modl.mod_loc, Not_included msg)) in
         let modl' =
           { mod_desc = Tmod_constraint(modl, mty_decl, coercion);
             mod_type = mty_decl;
           let coercion =
             try
               Includemod.modtypes env arg.mod_type mty_param
-            with Includemod.Error msg ->
-              raise(Error(sarg.pmod_loc, Not_included msg)) in
+            with Includemod.Error (env, msg) ->
+              raise(Error(env, sarg.pmod_loc, Not_included msg)) in
           let mty_appl =
             try
               let path = path_of_module arg in
                 Mtype.nondep_supertype
                   (Env.add_module param arg.mod_type env) param mty_res
               with Not_found ->
-                raise(Error(smod.pmod_loc,
+                raise(Error(env, smod.pmod_loc,
                             Cannot_eliminate_dependency mty_functor)) in
           rm { mod_desc = Tmod_apply(funct, arg, coercion);
                mod_type = mty_appl;
                mod_env = env;
                mod_loc = smod.pmod_loc }
       | _ ->
-          raise(Error(sfunct.pmod_loc, Cannot_apply funct.mod_type))
+          raise(Error(env, sfunct.pmod_loc, Cannot_apply funct.mod_type))
       end
   | Pmod_constraint(sarg, smty) ->
       let arg = type_module anchor env sarg in
       let coercion =
         try
           Includemod.modtypes env arg.mod_type mty
-        with Includemod.Error msg ->
-          raise(Error(sarg.pmod_loc, Not_included msg)) in
+        with Includemod.Error (env, msg) ->
+          raise(Error(env, sarg.pmod_loc, Not_included msg)) in
       rm { mod_desc = Tmod_constraint(arg, mty, coercion);
            mod_type = mty;
            mod_env = env;
         try
           find_in_path_uncap !Config.load_path (modulename ^ ".cmi")
         with Not_found ->
-          raise(Error(Location.none, Interface_not_compiled sourceintf)) in
+          raise(Error(Env.empty, Location.none, Interface_not_compiled sourceintf)) in
       let dclsig = Env.read_signature modulename intf_file in
       let coercion = Includemod.compunit sourcefile sg intf_file dclsig in
       (str, coercion)
          let sg = Env.read_signature modname (pref ^ ".cmi") in
          if Filename.check_suffix f ".cmi" &&
             not(Mtype.no_code_needed_sig Env.initial sg)
-         then raise(Error(Location.none, Implementation_is_required f));
+         then raise(Error(Env.empty, Location.none, Implementation_is_required f));
          (modname, Env.read_signature modname (pref ^ ".cmi")))
       objfiles in
   (* Compute signature of packaged unit *)
     chop_extension_if_any cmifile ^ !Config.interface_suffix in
   if Sys.file_exists mlifile then begin
     if not (Sys.file_exists cmifile) then begin
-      raise(Error(Location.in_file mlifile, Interface_not_compiled mlifile))
+      raise(Error(Env.empty, Location.in_file mlifile, Interface_not_compiled mlifile))
     end;
     let dclsig = Env.read_signature modulename cmifile in
     Includemod.compunit "(obtained by packing)" sg mlifile dclsig
 
 open Printtyp
 
-let report_error ppf = function
+let report_error env ppf = function
   | Unbound_module lid -> fprintf ppf "Unbound module %a" longident lid
   | Unbound_modtype lid -> fprintf ppf "Unbound module type %a" longident lid
   | Cannot_apply mty ->
         "@[This module is not a functor; it has type@ %a@]" modtype mty
   | Not_included errs ->
       fprintf ppf
-        "@[<v>Signature mismatch:@ %a@]" Includemod.report_error errs
+        "@[<v>Signature mismatch:@ %a@]" (Includemod.report_error env)
+	errs
   | Cannot_eliminate_dependency mty ->
       fprintf ppf
         "@[This functor has type@ %a@ \
              does not match its original definition@ \
              in the constrained signature:@]@ \
            %a@]"
-        longident lid Includemod.report_error explanation
+        longident lid (Includemod.report_error env) explanation
   | Repeated_name(kind, name) ->
       fprintf ppf
         "@[Multiple definition of the %s name %s.@ \
   | Interface_not_compiled intf_name ->
       fprintf ppf
         "@[Could not find the .cmi file for interface@ %s.@]" intf_name
+
+let report_error env ppf = 
+  Printtyp.under_env env (report_error env ppf)

File typing/typemod.mli

   | Implementation_is_required of string
   | Interface_not_compiled of string
 
-exception Error of Location.t * error
+exception Error of Env.t * Location.t * error
 
-val report_error: formatter -> error -> unit
+val report_error: Env.t -> formatter -> error -> unit

File typing/typetexp.ml

   | Invalid_variable_name of string
   | Cannot_quantify of string * type_expr
 
-exception Error of Location.t * error
+exception Error of Env.t * Location.t * error
 
 type variable_context = int * (string, type_expr) Tbl.t
 
 let enter_type_variable strict loc name =
   try
     if name <> "" && name.[0] = '_' then
-      raise (Error (loc, Invalid_variable_name ("'" ^ name)));
+      raise (Error (Env.empty, loc, Invalid_variable_name ("'" ^ name)));
     let v = Tbl.find name !type_variables in
     if strict then raise Already_bound;
     v
   try
     Tbl.find name !type_variables
   with Not_found ->
-    raise(Error(loc, Unbound_type_variable ("'" ^ name)))
+    raise(Error(Env.empty, loc, Unbound_type_variable ("'" ^ name)))
 
 let wrap_method ty =
   match (Ctype.repr ty).desc with
     Ptyp_any ->
       if policy = Univars then new_pre_univar () else
       if policy = Fixed then
-        raise (Error (styp.ptyp_loc, Unbound_type_variable "_"))
+        raise (Error (env, styp.ptyp_loc, Unbound_type_variable "_"))
       else newvar ()
   | Ptyp_var name ->
       if name <> "" && name.[0] = '_' then
-        raise (Error (styp.ptyp_loc, Invalid_variable_name ("'" ^ name)));
+        raise (Error (env, styp.ptyp_loc, Invalid_variable_name ("'" ^ name)));
       begin try
         instance (List.assoc name !univars)
       with Not_found -> try
         try
           Env.lookup_type lid env
         with Not_found ->
-          raise(Error(styp.ptyp_loc, Unbound_type_constructor lid)) in
+          raise(Error(env, styp.ptyp_loc, Unbound_type_constructor lid)) in
       if List.length stl <> decl.type_arity then
-        raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid, decl.type_arity,
+        raise(Error(env, styp.ptyp_loc, Type_arity_mismatch(lid, decl.type_arity,
                                                            List.length stl)));
       let args = List.map (transl_type env policy) stl in
       let params = Ctype.instance_list decl.type_params in
       List.iter2
         (fun (sty, ty) ty' ->
            try unify_param env ty' ty with Unify trace ->
-             raise (Error(sty.ptyp_loc, Type_mismatch (swap_list trace))))
+             raise (Error(env, sty.ptyp_loc, Type_mismatch (swap_list trace))))
         (List.combine stl args) params;
       let constr = newconstr path args in
       begin try
         Ctype.enforce_constraints env constr
       with Unify trace ->
-        raise (Error(styp.ptyp_loc, Type_mismatch trace))
+        raise (Error(env, styp.ptyp_loc, Type_mismatch trace))
       end;
       constr
   | Ptyp_object fields ->
           let (path, decl) = Env.lookup_type lid2 env in
           (path, decl, false)
         with Not_found ->
-          raise(Error(styp.ptyp_loc, Unbound_class lid))
+          raise(Error(env, styp.ptyp_loc, Unbound_class lid))
       in
       if List.length stl <> decl.type_arity then
-        raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid, decl.type_arity,
+        raise(Error(env, styp.ptyp_loc, Type_arity_mismatch(lid, decl.type_arity,
                                                        List.length stl)));
       let args = List.map (transl_type env policy) stl in
       let params = Ctype.instance_list decl.type_params in
       List.iter2
         (fun (sty, ty) ty' ->
            try unify_var env ty' ty with Unify trace ->
-             raise (Error(sty.ptyp_loc, Type_mismatch (swap_list trace))))
+             raise (Error(env, sty.ptyp_loc, Type_mismatch (swap_list trace))))
         (List.combine stl args) params;
       let ty =
         try Ctype.expand_head env (newconstr path args)
         with Unify trace ->
-          raise (Error(styp.ptyp_loc, Type_mismatch trace))
+          raise (Error(env, styp.ptyp_loc, Type_mismatch trace))
       in
       begin match ty.desc with
         Tvariant row ->
           let row = Btype.row_repr row in
           List.iter
             (fun l -> if not (List.mem_assoc l row.row_fields) then
-              raise(Error(styp.ptyp_loc, Present_has_no_type l)))
+              raise(Error(env, styp.ptyp_loc, Present_has_no_type l)))
             present;
           let fields =
             List.map
           let ty = transl_type env policy st in
           begin try unify_var env t ty with Unify trace ->
             let trace = swap_list trace in
-            raise(Error(styp.ptyp_loc, Alias_type_mismatch trace))
+            raise(Error(env, styp.ptyp_loc, Alias_type_mismatch trace))
           end;
           ty
         with Not_found ->
           let ty = transl_type env policy st in
           begin try unify_var env t ty with Unify trace ->
             let trace = swap_list trace in
-            raise(Error(styp.ptyp_loc, Alias_type_mismatch trace))
+            raise(Error(env, styp.ptyp_loc, Alias_type_mismatch trace))
           end;
           if !Clflags.principal then begin
             end_def ();
         try
           let (l',f') = Hashtbl.find hfields h in
           (* Check for tag conflicts *)
-          if l <> l' then raise(Error(styp.ptyp_loc, Variant_tags(l, l')));
+          if l <> l' then raise(Error(env, styp.ptyp_loc, Variant_tags(l, l')));
           let ty = mkfield l f and ty' = mkfield l f' in
           if equal env false [ty] [ty'] then () else
           try unify env ty ty'
-          with Unify trace -> raise(Error(loc, Constructor_mismatch (ty,ty')))
+          with Unify trace -> raise(Error(env, loc, Constructor_mismatch (ty,ty')))
         with Not_found ->
           Hashtbl.add hfields h (l,f)
       in
                 Reither(c, tl, false, ref None)
             | _ ->
                 if List.length stl > 1 || c && stl <> [] then
-                  raise(Error(styp.ptyp_loc, Present_has_conjunction l));
+                  raise(Error(env, styp.ptyp_loc, Present_has_conjunction l));
                 match stl with [] -> Rpresent None
                 | st :: _ -> Rpresent (Some(transl_type env policy st))
             in
                 let row = Btype.row_repr row in
                 row.row_fields
             | {desc=Tvar}, Some(p, _) ->
-                raise(Error(sty.ptyp_loc, Unbound_type_constructor_2 p)) 
+                raise(Error(env, sty.ptyp_loc, Unbound_type_constructor_2 p)) 
             | _ ->
-                raise(Error(sty.ptyp_loc, Not_a_variant ty))
+                raise(Error(env, sty.ptyp_loc, Not_a_variant ty))
             in
             List.iter
               (fun (l, f) ->
       | Some present ->
           List.iter
             (fun l -> if not (List.mem_assoc l fields) then
-              raise(Error(styp.ptyp_loc, Present_has_no_type l)))
+              raise(Error(env, styp.ptyp_loc, Present_has_no_type l)))
             present
       end;
       let row =
             let v = Btype.proxy ty1 in
             if deep_occur v ty then begin
               if v.level <> Btype.generic_level || v.desc <> Tvar then
-                raise (Error (styp.ptyp_loc, Cannot_quantify (name, v)));
+                raise (Error (env, styp.ptyp_loc, Cannot_quantify (name, v)));
               v.desc <- Tunivar;
               v :: tyl
             end else tyl)
         r := (loc, v,  Tbl.find name !type_variables) :: !r
       with Not_found ->
         if fixed && (repr ty).desc = Tvar then
-          raise(Error(loc, Unbound_type_variable ("'"^name)));
+          raise(Error(env, loc, Unbound_type_variable ("'"^name)));
         let v2 = new_global_var () in
         r := (loc, v, v2) :: !r;
         type_variables := Tbl.add name v2 !type_variables)
     List.iter
       (function (loc, t1, t2) ->
         try unify env t1 t2 with Unify trace ->
-          raise (Error(loc, Type_mismatch trace)))
+          raise (Error(env, loc, Type_mismatch trace)))
       !r
 
 let transl_simple_type env fixed styp =
         (if v.desc = Tvar then "it escapes this scope" else
          if v.desc = Tunivar then "it is aliased to another variable"
          else "it is not a variable")
+
+let report_error env ppf =
+  Printtyp.under_env env (report_error ppf)

File typing/typetexp.mli

   | Invalid_variable_name of string
   | Cannot_quantify of string * Types.type_expr
 
-exception Error of Location.t * error
+exception Error of Env.t * Location.t * error
 
-val report_error: formatter -> error -> unit
+val report_error: Env.t -> formatter -> error -> unit