path: root/experimental/garrigue/module-errors.diff

Index: typing/includemod.ml
===================================================================
--- typing/includemod.ml	(revision 11161)
+++ typing/includemod.ml	(working copy)
@@ -19,7 +19,7 @@
 open Types
 open Typedtree
 
-type error =
+type symptom =
     Missing_field of Ident.t
   | Value_descriptions of Ident.t * value_description * value_description
   | Type_declarations of Ident.t * type_declaration
@@ -38,6 +38,10 @@
       Ctype.class_match_failure list
   | Unbound_modtype_path of Path.t
 
+type pos =
+    Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
+type error = pos list * symptom
+
 exception Error of error list
 
 (* All functions "blah env x1 x2" check that x1 is included in x2,
@@ -46,51 +50,52 @@
 
 (* Inclusion between value descriptions *)
 
-let value_descriptions env subst id vd1 vd2 =
+let value_descriptions env cxt subst id vd1 vd2 =
   let vd2 = Subst.value_description subst vd2 in
   try
     Includecore.value_descriptions env vd1 vd2
   with Includecore.Dont_match ->
-    raise(Error[Value_descriptions(id, vd1, vd2)])
+    raise(Error[cxt, Value_descriptions(id, vd1, vd2)])
 
 (* Inclusion between type declarations *)
 
-let type_declarations env subst id decl1 decl2 =
+let type_declarations env cxt subst id decl1 decl2 =
   let decl2 = Subst.type_declaration subst decl2 in
   let err = Includecore.type_declarations env id decl1 decl2 in
-  if err <> [] then raise(Error[Type_declarations(id, decl1, decl2, err)])
+  if err <> [] then raise(Error[cxt, Type_declarations(id, decl1, decl2, err)])
 
 (* Inclusion between exception declarations *)
 
-let exception_declarations env subst id decl1 decl2 =
+let exception_declarations env cxt subst id decl1 decl2 =
   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[cxt, Exception_declarations(id, decl1, decl2)])
 
 (* Inclusion between class declarations *)
 
-let class_type_declarations env subst id decl1 decl2 =
+let class_type_declarations env cxt subst id decl1 decl2 =
   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[cxt, Class_type_declarations(id, decl1, decl2, reason)])
 
-let class_declarations env subst id decl1 decl2 =
+let class_declarations env cxt 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[cxt, Class_declarations(id, decl1, decl2, reason)])
 
 (* Expand a module type identifier when possible *)
 
 exception Dont_match
 
-let expand_module_path env path =
+let expand_module_path env cxt path =
   try
     Env.find_modtype_expansion path env
   with Not_found ->
-    raise(Error[Unbound_modtype_path path])
+    raise(Error[cxt, Unbound_modtype_path path])
 
 (* Extract name, kind and ident from a signature item *)
 
@@ -128,28 +133,29 @@
    Return the restriction that transforms a value of the smaller type
    into a value of the bigger type. *)
 
-let rec modtypes env subst mty1 mty2 =
+let rec modtypes env cxt subst mty1 mty2 =
   try
-    try_modtypes env subst mty1 mty2
+    try_modtypes env cxt subst mty1 mty2
   with
     Dont_match ->
-      raise(Error[Module_types(mty1, Subst.modtype subst mty2)])
+      raise(Error[cxt, Module_types(mty1, Subst.modtype subst mty2)])
   | Error reasons ->
-      raise(Error(Module_types(mty1, Subst.modtype subst mty2) :: reasons))
+      raise(Error((cxt, Module_types(mty1, Subst.modtype subst mty2))
+                  :: reasons))
 
-and try_modtypes env subst mty1 mty2 =
+and try_modtypes env cxt subst mty1 mty2 =
   match (mty1, mty2) with
     (_, Tmty_ident p2) ->
-      try_modtypes2 env mty1 (Subst.modtype subst mty2)
+      try_modtypes2 env cxt mty1 (Subst.modtype subst mty2)
   | (Tmty_ident p1, _) ->
-      try_modtypes env subst (expand_module_path env p1) mty2
+      try_modtypes env cxt subst (expand_module_path env cxt p1) mty2
   | (Tmty_signature sig1, Tmty_signature sig2) ->
-      signatures env subst sig1 sig2
+      signatures env cxt subst sig1 sig2
   | (Tmty_functor(param1, arg1, res1), Tmty_functor(param2, arg2, res2)) ->
       let arg2' = Subst.modtype subst arg2 in
-      let cc_arg = modtypes env Subst.identity arg2' arg1 in
+      let cc_arg = modtypes env (Arg param1::cxt) Subst.identity arg2' arg1 in
       let cc_res =
-        modtypes (Env.add_module param1 arg2' env)
+        modtypes (Env.add_module param1 arg2' env) (Body param1::cxt)
           (Subst.add_module param2 (Pident param1) subst) res1 res2 in
       begin match (cc_arg, cc_res) with
           (Tcoerce_none, Tcoerce_none) -> Tcoerce_none
@@ -158,19 +164,19 @@
   | (_, _) ->
       raise Dont_match
 
-and try_modtypes2 env mty1 mty2 =
+and try_modtypes2 env cxt mty1 mty2 =
   (* mty2 is an identifier *)
   match (mty1, mty2) with
     (Tmty_ident p1, Tmty_ident p2) when Path.same p1 p2 ->
       Tcoerce_none
   | (_, Tmty_ident p2) ->
-      try_modtypes env Subst.identity mty1 (expand_module_path env p2)
+      try_modtypes env cxt Subst.identity mty1 (expand_module_path env cxt p2)
   | (_, _) ->
       assert false
 
 (* Inclusion between signatures *)
 
-and signatures env subst sig1 sig2 =
+and signatures env cxt subst sig1 sig2 =
   (* Environment used to check inclusion of components *)
   let new_env =
     Env.add_signature sig1 env in
@@ -202,7 +208,7 @@
   let rec pair_components subst paired unpaired = function
       [] ->
         begin match unpaired with
-            [] -> signature_components new_env subst (List.rev paired)
+            [] -> signature_components new_env cxt subst (List.rev paired)
           | _  -> raise(Error unpaired)
         end
     | item2 :: rem ->
@@ -234,7 +240,7 @@
             ((item1, item2, pos1) :: paired) unpaired rem
         with Not_found ->
           let unpaired =
-            if report then Missing_field id2 :: unpaired else unpaired in
+            if report then (cxt, Missing_field id2) :: unpaired else unpaired in
           pair_components subst paired unpaired rem
         end in
   (* Do the pairing and checking, and return the final coercion *)
@@ -242,65 +248,67 @@
 
 (* Inclusion between signature components *)
 
-and signature_components env subst = function
+and signature_components env cxt subst = function
     [] -> []
   | (Tsig_value(id1, valdecl1), Tsig_value(id2, valdecl2), pos) :: rem ->
-      let cc = value_descriptions env subst id1 valdecl1 valdecl2 in
+      let cc = value_descriptions env cxt subst id1 valdecl1 valdecl2 in
       begin match valdecl2.val_kind with
-        Val_prim p -> signature_components env subst rem
-      | _ -> (pos, cc) :: signature_components env subst rem
+        Val_prim p -> signature_components env cxt subst rem
+      | _ -> (pos, cc) :: signature_components env cxt subst rem
       end
   | (Tsig_type(id1, tydecl1, _), Tsig_type(id2, tydecl2, _), pos) :: rem ->
-      type_declarations env subst id1 tydecl1 tydecl2;
-      signature_components env subst rem
+      type_declarations env cxt subst id1 tydecl1 tydecl2;
+      signature_components env cxt subst rem
   | (Tsig_exception(id1, excdecl1), Tsig_exception(id2, excdecl2), pos)
     :: rem ->
-      exception_declarations env subst id1 excdecl1 excdecl2;
-      (pos, Tcoerce_none) :: signature_components env subst rem
+      exception_declarations env cxt subst id1 excdecl1 excdecl2;
+      (pos, Tcoerce_none) :: signature_components env cxt subst rem
   | (Tsig_module(id1, mty1, _), Tsig_module(id2, mty2, _), pos) :: rem ->
       let cc =
-        modtypes env subst (Mtype.strengthen env mty1 (Pident id1)) mty2 in
-      (pos, cc) :: signature_components env subst rem
+        modtypes env (Module id1::cxt) subst
+          (Mtype.strengthen env mty1 (Pident id1)) mty2 in
+      (pos, cc) :: signature_components env cxt subst rem
   | (Tsig_modtype(id1, info1), Tsig_modtype(id2, info2), pos) :: rem ->
-      modtype_infos env subst id1 info1 info2;
-      signature_components env subst rem
+      modtype_infos env cxt subst id1 info1 info2;
+      signature_components env cxt subst rem
   | (Tsig_class(id1, decl1, _), Tsig_class(id2, decl2, _), pos) :: rem ->
-      class_declarations env subst id1 decl1 decl2;
-      (pos, Tcoerce_none) :: signature_components env subst rem
+      class_declarations env cxt subst id1 decl1 decl2;
+      (pos, Tcoerce_none) :: signature_components env cxt subst rem
   | (Tsig_cltype(id1, info1, _), Tsig_cltype(id2, info2, _), pos) :: rem ->
-      class_type_declarations env subst id1 info1 info2;
-      signature_components env subst rem
+      class_type_declarations env cxt subst id1 info1 info2;
+      signature_components env cxt subst rem
   | _ ->
       assert false
 
 (* Inclusion between module type specifications *)
 
-and modtype_infos env subst id info1 info2 =
+and modtype_infos env cxt subst id info1 info2 =
   let info2 = Subst.modtype_declaration subst info2 in
+  let cxt' = Modtype id :: cxt in
   try
     match (info1, info2) with
       (Tmodtype_abstract, Tmodtype_abstract) -> ()
     | (Tmodtype_manifest mty1, Tmodtype_abstract) -> ()
     | (Tmodtype_manifest mty1, Tmodtype_manifest mty2) ->
-        check_modtype_equiv env mty1 mty2
+        check_modtype_equiv env cxt' mty1 mty2
     | (Tmodtype_abstract, Tmodtype_manifest mty2) ->
-        check_modtype_equiv env (Tmty_ident(Pident id)) mty2
+        check_modtype_equiv env cxt' (Tmty_ident(Pident id)) mty2
   with Error reasons ->
-    raise(Error(Modtype_infos(id, info1, info2) :: reasons))
+    raise(Error((cxt, Modtype_infos(id, info1, info2)) :: reasons))
 
-and check_modtype_equiv env mty1 mty2 =
+and check_modtype_equiv env cxt mty1 mty2 =
   match
-    (modtypes env Subst.identity mty1 mty2,
-     modtypes env Subst.identity mty2 mty1)
+    (modtypes env cxt Subst.identity mty1 mty2,
+     modtypes env cxt Subst.identity mty2 mty1)
   with
     (Tcoerce_none, Tcoerce_none) -> ()
-  | (_, _) -> raise(Error [Modtype_permutation])
+  | (_, _) -> raise(Error [cxt, Modtype_permutation])
 
 (* Simplified inclusion check between module types (for Env) *)
 
 let check_modtype_inclusion env mty1 path1 mty2 =
   try
-    ignore(modtypes env Subst.identity
+    ignore(modtypes env [] Subst.identity
                     (Mtype.strengthen env mty1 path1) mty2)
   with Error reasons ->
     raise Not_found
@@ -312,16 +320,16 @@
 
 let compunit impl_name impl_sig intf_name intf_sig =
   try
-    signatures Env.initial Subst.identity impl_sig intf_sig
+    signatures Env.initial [] Subst.identity impl_sig intf_sig
   with Error reasons ->
-    raise(Error(Interface_mismatch(impl_name, intf_name) :: reasons))
+    raise(Error(([], Interface_mismatch(impl_name, intf_name)) :: reasons))
 
-(* Hide the substitution parameter to the outside world *)
+(* Hide the context and substitution parameters to the outside world *)
 
-let modtypes env mty1 mty2 = modtypes env Subst.identity mty1 mty2
-let signatures env sig1 sig2 = signatures env Subst.identity sig1 sig2
+let modtypes env mty1 mty2 = modtypes env [] Subst.identity mty1 mty2
+let signatures env sig1 sig2 = signatures env [] Subst.identity sig1 sig2
 let type_declarations env id decl1 decl2 =
-  type_declarations env Subst.identity id decl1 decl2
+  type_declarations env [] Subst.identity id decl1 decl2
 
 (* Error report *)
 
@@ -384,9 +392,62 @@
   | Unbound_modtype_path path ->
       fprintf ppf "Unbound module type %a" Printtyp.path path
 
-let report_error ppf = function
-  |  [] -> ()
-  | err :: errs ->
-      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 rec context ppf = function
+    Module id :: rem ->
+      fprintf ppf "@[<2>module %a%a@]" ident id args rem
+  | Modtype id :: rem ->
+      fprintf ppf "@[<2>module type %a =@ %a@]" ident id context_mty rem
+  | Body x :: rem ->
+      fprintf ppf "functor (%a) ->@ %a" ident x context_mty rem
+  | Arg x :: rem ->
+      fprintf ppf "functor (%a : %a) -> ..." ident x context_mty rem
+  | [] ->
+      fprintf ppf "<here>"
+and context_mty ppf = function
+    (Module _ | Modtype _) :: _ as rem ->
+      fprintf ppf "@[<2>sig@ %a@;<1 -2>end@]" context rem
+  | cxt -> context ppf cxt
+and args ppf = function
+    Body x :: rem ->
+      fprintf ppf "(%a)%a" ident x args rem
+  | Arg x :: rem ->
+      fprintf ppf "(%a :@ %a) : ..." ident x context_mty rem
+  | cxt ->
+      fprintf ppf " :@ %a" context_mty cxt
+
+let path_of_context = function
+    Module id :: rem ->
+      let rec subm path = function
+          [] -> path
+        | Module id :: rem -> subm (Pdot (path, Ident.name id, -1)) rem
+        | _ -> assert false
+      in subm (Pident id) rem
+  | _ -> assert false
+
+let context ppf cxt =
+  if cxt = [] then () else
+  if List.for_all (function Module _ -> true | _ -> false) cxt then
+    fprintf ppf "In module %a:@ " path (path_of_context cxt)
+  else
+    fprintf ppf "@[<hv 2>At position@ %a@]@ " context cxt
+
+let include_err ppf (cxt, err) =
+  fprintf ppf "@[<v>%a%a@]" context (List.rev cxt) include_err err
+
+let max_size = 500
+let buffer = String.create max_size
+let is_big obj =
+  try ignore (Marshal.to_buffer buffer 0 max_size obj []); false
+  with _ -> true
+
+let report_error ppf errs =
+  if errs = [] then () else
+  let (errs , err) = split_last errs in
+  let pe = ref true in
+  let include_err' ppf err =
+    if !Clflags.show_trace || not (is_big err) then
+      fprintf ppf "%a@ " include_err err
+    else if !pe then (fprintf ppf "...@ "; pe := false)
+  in
+  let print_errs ppf = List.iter (include_err' ppf) in
+  fprintf ppf "@[<v>%a%a@]" print_errs errs include_err err
Index: typing/includemod.mli
===================================================================
--- typing/includemod.mli	(revision 11161)
+++ typing/includemod.mli	(working copy)
@@ -24,7 +24,7 @@
 val type_declarations:
       Env.t -> Ident.t -> type_declaration -> type_declaration -> unit
 
-type error =
+type symptom =
     Missing_field of Ident.t
   | Value_descriptions of Ident.t * value_description * value_description
   | Type_declarations of Ident.t * type_declaration
@@ -43,6 +43,10 @@
       Ctype.class_match_failure list
   | Unbound_modtype_path of Path.t
 
+type pos =
+    Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
+type error = pos list * symptom
+
 exception Error of error list
 
 val report_error: formatter -> error list -> unit
Index: utils/clflags.ml
===================================================================
--- utils/clflags.ml	(revision 11161)
+++ utils/clflags.ml	(working copy)
@@ -53,6 +53,7 @@
 and dllpaths = ref ([] : string list)   (* -dllpath *)
 and make_package = ref false            (* -pack *)
 and for_package = ref (None: string option) (* -for-pack *)
+and show_trace = ref false              (* -show-trace *)
 let dump_parsetree = ref false          (* -dparsetree *)
 and dump_rawlambda = ref false          (* -drawlambda *)
 and dump_lambda = ref false             (* -dlambda *)
Index: utils/clflags.mli
===================================================================
--- utils/clflags.mli	(revision 11161)
+++ utils/clflags.mli	(working copy)
@@ -50,6 +50,7 @@
 val dllpaths : string list ref
 val make_package : bool ref
 val for_package : string option ref
+val show_trace : bool ref
 val dump_parsetree : bool ref
 val dump_rawlambda : bool ref
 val dump_lambda : bool ref