patch for better module errors

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

1 files changed, 403 insertions, 0 deletions

diff --git a/experimental/garrigue/module-errors.diffs b/experimental/garrigue/module-errors.diffs
new file mode 100644
index 000000000..2f8c2bc28
--- /dev/null
+++ b/experimental/garrigue/module-errors.diffs
@@ -0,0 +1,403 @@
+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