Shorter error messages for modules
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@11225 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02master
parent
854afdd4e9
commit
efa8d8896d
|
@ -19,7 +19,7 @@ open Path
|
||||||
open Types
|
open Types
|
||||||
open Typedtree
|
open Typedtree
|
||||||
|
|
||||||
type error =
|
type symptom =
|
||||||
Missing_field of Ident.t
|
Missing_field of Ident.t
|
||||||
| Value_descriptions of Ident.t * value_description * value_description
|
| Value_descriptions of Ident.t * value_description * value_description
|
||||||
| Type_declarations of Ident.t * type_declaration
|
| Type_declarations of Ident.t * type_declaration
|
||||||
|
@ -38,6 +38,10 @@ type error =
|
||||||
Ctype.class_match_failure list
|
Ctype.class_match_failure list
|
||||||
| Unbound_modtype_path of Path.t
|
| 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
|
exception Error of error list
|
||||||
|
|
||||||
(* All functions "blah env x1 x2" check that x1 is included in x2,
|
(* All functions "blah env x1 x2" check that x1 is included in x2,
|
||||||
|
@ -46,51 +50,52 @@ exception Error of error list
|
||||||
|
|
||||||
(* Inclusion between value descriptions *)
|
(* 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
|
let vd2 = Subst.value_description subst vd2 in
|
||||||
try
|
try
|
||||||
Includecore.value_descriptions env vd1 vd2
|
Includecore.value_descriptions env vd1 vd2
|
||||||
with Includecore.Dont_match ->
|
with Includecore.Dont_match ->
|
||||||
raise(Error[Value_descriptions(id, vd1, vd2)])
|
raise(Error[cxt, Value_descriptions(id, vd1, vd2)])
|
||||||
|
|
||||||
(* Inclusion between type declarations *)
|
(* 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 decl2 = Subst.type_declaration subst decl2 in
|
||||||
let err = Includecore.type_declarations env id decl1 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 *)
|
(* 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
|
let decl2 = Subst.exception_declaration subst decl2 in
|
||||||
if Includecore.exception_declarations env decl1 decl2
|
if Includecore.exception_declarations env decl1 decl2
|
||||||
then ()
|
then ()
|
||||||
else raise(Error[Exception_declarations(id, decl1, decl2)])
|
else raise(Error[cxt, Exception_declarations(id, decl1, decl2)])
|
||||||
|
|
||||||
(* Inclusion between class declarations *)
|
(* 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
|
let decl2 = Subst.cltype_declaration subst decl2 in
|
||||||
match Includeclass.class_type_declarations env decl1 decl2 with
|
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
|
let decl2 = Subst.class_declaration subst decl2 in
|
||||||
match Includeclass.class_declarations env decl1 decl2 with
|
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 *)
|
(* Expand a module type identifier when possible *)
|
||||||
|
|
||||||
exception Dont_match
|
exception Dont_match
|
||||||
|
|
||||||
let expand_module_path env path =
|
let expand_module_path env cxt path =
|
||||||
try
|
try
|
||||||
Env.find_modtype_expansion path env
|
Env.find_modtype_expansion path env
|
||||||
with Not_found ->
|
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 *)
|
(* Extract name, kind and ident from a signature item *)
|
||||||
|
|
||||||
|
@ -128,28 +133,29 @@ let simplify_structure_coercion cc =
|
||||||
Return the restriction that transforms a value of the smaller type
|
Return the restriction that transforms a value of the smaller type
|
||||||
into a value of the bigger 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
|
||||||
try_modtypes env subst mty1 mty2
|
try_modtypes env cxt subst mty1 mty2
|
||||||
with
|
with
|
||||||
Dont_match ->
|
Dont_match ->
|
||||||
raise(Error[Module_types(mty1, Subst.modtype subst mty2)])
|
raise(Error[cxt, Module_types(mty1, Subst.modtype subst mty2)])
|
||||||
| Error reasons ->
|
| 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
|
match (mty1, mty2) with
|
||||||
(_, Tmty_ident p2) ->
|
(_, Tmty_ident p2) ->
|
||||||
try_modtypes2 env mty1 (Subst.modtype subst mty2)
|
try_modtypes2 env cxt mty1 (Subst.modtype subst mty2)
|
||||||
| (Tmty_ident p1, _) ->
|
| (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) ->
|
| (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)) ->
|
| (Tmty_functor(param1, arg1, res1), Tmty_functor(param2, arg2, res2)) ->
|
||||||
let arg2' = Subst.modtype subst arg2 in
|
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 =
|
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
|
(Subst.add_module param2 (Pident param1) subst) res1 res2 in
|
||||||
begin match (cc_arg, cc_res) with
|
begin match (cc_arg, cc_res) with
|
||||||
(Tcoerce_none, Tcoerce_none) -> Tcoerce_none
|
(Tcoerce_none, Tcoerce_none) -> Tcoerce_none
|
||||||
|
@ -158,19 +164,19 @@ and try_modtypes env subst mty1 mty2 =
|
||||||
| (_, _) ->
|
| (_, _) ->
|
||||||
raise Dont_match
|
raise Dont_match
|
||||||
|
|
||||||
and try_modtypes2 env mty1 mty2 =
|
and try_modtypes2 env cxt mty1 mty2 =
|
||||||
(* mty2 is an identifier *)
|
(* mty2 is an identifier *)
|
||||||
match (mty1, mty2) with
|
match (mty1, mty2) with
|
||||||
(Tmty_ident p1, Tmty_ident p2) when Path.same p1 p2 ->
|
(Tmty_ident p1, Tmty_ident p2) when Path.same p1 p2 ->
|
||||||
Tcoerce_none
|
Tcoerce_none
|
||||||
| (_, Tmty_ident p2) ->
|
| (_, 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
|
assert false
|
||||||
|
|
||||||
(* Inclusion between signatures *)
|
(* Inclusion between signatures *)
|
||||||
|
|
||||||
and signatures env subst sig1 sig2 =
|
and signatures env cxt subst sig1 sig2 =
|
||||||
(* Environment used to check inclusion of components *)
|
(* Environment used to check inclusion of components *)
|
||||||
let new_env =
|
let new_env =
|
||||||
Env.add_signature sig1 env in
|
Env.add_signature sig1 env in
|
||||||
|
@ -202,7 +208,7 @@ and signatures env subst sig1 sig2 =
|
||||||
let rec pair_components subst paired unpaired = function
|
let rec pair_components subst paired unpaired = function
|
||||||
[] ->
|
[] ->
|
||||||
begin match unpaired with
|
begin match unpaired with
|
||||||
[] -> signature_components new_env subst (List.rev paired)
|
[] -> signature_components new_env cxt subst (List.rev paired)
|
||||||
| _ -> raise(Error unpaired)
|
| _ -> raise(Error unpaired)
|
||||||
end
|
end
|
||||||
| item2 :: rem ->
|
| item2 :: rem ->
|
||||||
|
@ -234,7 +240,7 @@ and signatures env subst sig1 sig2 =
|
||||||
((item1, item2, pos1) :: paired) unpaired rem
|
((item1, item2, pos1) :: paired) unpaired rem
|
||||||
with Not_found ->
|
with Not_found ->
|
||||||
let unpaired =
|
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
|
pair_components subst paired unpaired rem
|
||||||
end in
|
end in
|
||||||
(* Do the pairing and checking, and return the final coercion *)
|
(* Do the pairing and checking, and return the final coercion *)
|
||||||
|
@ -242,65 +248,67 @@ and signatures env subst sig1 sig2 =
|
||||||
|
|
||||||
(* Inclusion between signature components *)
|
(* 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 ->
|
| (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
|
begin match valdecl2.val_kind with
|
||||||
Val_prim p -> signature_components env subst rem
|
Val_prim p -> signature_components env cxt subst rem
|
||||||
| _ -> (pos, cc) :: signature_components env subst rem
|
| _ -> (pos, cc) :: signature_components env cxt subst rem
|
||||||
end
|
end
|
||||||
| (Tsig_type(id1, tydecl1, _), Tsig_type(id2, tydecl2, _), pos) :: rem ->
|
| (Tsig_type(id1, tydecl1, _), Tsig_type(id2, tydecl2, _), pos) :: rem ->
|
||||||
type_declarations env subst id1 tydecl1 tydecl2;
|
type_declarations env cxt subst id1 tydecl1 tydecl2;
|
||||||
signature_components env subst rem
|
signature_components env cxt subst rem
|
||||||
| (Tsig_exception(id1, excdecl1), Tsig_exception(id2, excdecl2), pos)
|
| (Tsig_exception(id1, excdecl1), Tsig_exception(id2, excdecl2), pos)
|
||||||
:: rem ->
|
:: rem ->
|
||||||
exception_declarations env subst id1 excdecl1 excdecl2;
|
exception_declarations env cxt subst id1 excdecl1 excdecl2;
|
||||||
(pos, Tcoerce_none) :: signature_components env subst rem
|
(pos, Tcoerce_none) :: signature_components env cxt subst rem
|
||||||
| (Tsig_module(id1, mty1, _), Tsig_module(id2, mty2, _), pos) :: rem ->
|
| (Tsig_module(id1, mty1, _), Tsig_module(id2, mty2, _), pos) :: rem ->
|
||||||
let cc =
|
let cc =
|
||||||
modtypes env subst (Mtype.strengthen env mty1 (Pident id1)) mty2 in
|
modtypes env (Module id1::cxt) subst
|
||||||
(pos, cc) :: signature_components env subst rem
|
(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 ->
|
| (Tsig_modtype(id1, info1), Tsig_modtype(id2, info2), pos) :: rem ->
|
||||||
modtype_infos env subst id1 info1 info2;
|
modtype_infos env cxt subst id1 info1 info2;
|
||||||
signature_components env subst rem
|
signature_components env cxt subst rem
|
||||||
| (Tsig_class(id1, decl1, _), Tsig_class(id2, decl2, _), pos) :: rem ->
|
| (Tsig_class(id1, decl1, _), Tsig_class(id2, decl2, _), pos) :: rem ->
|
||||||
class_declarations env subst id1 decl1 decl2;
|
class_declarations env cxt subst id1 decl1 decl2;
|
||||||
(pos, Tcoerce_none) :: signature_components env subst rem
|
(pos, Tcoerce_none) :: signature_components env cxt subst rem
|
||||||
| (Tsig_cltype(id1, info1, _), Tsig_cltype(id2, info2, _), pos) :: rem ->
|
| (Tsig_cltype(id1, info1, _), Tsig_cltype(id2, info2, _), pos) :: rem ->
|
||||||
class_type_declarations env subst id1 info1 info2;
|
class_type_declarations env cxt subst id1 info1 info2;
|
||||||
signature_components env subst rem
|
signature_components env cxt subst rem
|
||||||
| _ ->
|
| _ ->
|
||||||
assert false
|
assert false
|
||||||
|
|
||||||
(* Inclusion between module type specifications *)
|
(* 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 info2 = Subst.modtype_declaration subst info2 in
|
||||||
|
let cxt' = Modtype id :: cxt in
|
||||||
try
|
try
|
||||||
match (info1, info2) with
|
match (info1, info2) with
|
||||||
(Tmodtype_abstract, Tmodtype_abstract) -> ()
|
(Tmodtype_abstract, Tmodtype_abstract) -> ()
|
||||||
| (Tmodtype_manifest mty1, Tmodtype_abstract) -> ()
|
| (Tmodtype_manifest mty1, Tmodtype_abstract) -> ()
|
||||||
| (Tmodtype_manifest mty1, Tmodtype_manifest mty2) ->
|
| (Tmodtype_manifest mty1, Tmodtype_manifest mty2) ->
|
||||||
check_modtype_equiv env mty1 mty2
|
check_modtype_equiv env cxt' mty1 mty2
|
||||||
| (Tmodtype_abstract, Tmodtype_manifest 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 ->
|
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
|
match
|
||||||
(modtypes env Subst.identity mty1 mty2,
|
(modtypes env cxt Subst.identity mty1 mty2,
|
||||||
modtypes env Subst.identity mty2 mty1)
|
modtypes env cxt Subst.identity mty2 mty1)
|
||||||
with
|
with
|
||||||
(Tcoerce_none, Tcoerce_none) -> ()
|
(Tcoerce_none, Tcoerce_none) -> ()
|
||||||
| (_, _) -> raise(Error [Modtype_permutation])
|
| (_, _) -> raise(Error [cxt, Modtype_permutation])
|
||||||
|
|
||||||
(* Simplified inclusion check between module types (for Env) *)
|
(* Simplified inclusion check between module types (for Env) *)
|
||||||
|
|
||||||
let check_modtype_inclusion env mty1 path1 mty2 =
|
let check_modtype_inclusion env mty1 path1 mty2 =
|
||||||
try
|
try
|
||||||
ignore(modtypes env Subst.identity
|
ignore(modtypes env [] Subst.identity
|
||||||
(Mtype.strengthen env mty1 path1) mty2)
|
(Mtype.strengthen env mty1 path1) mty2)
|
||||||
with Error reasons ->
|
with Error reasons ->
|
||||||
raise Not_found
|
raise Not_found
|
||||||
|
@ -312,16 +320,16 @@ let _ = Env.check_modtype_inclusion := check_modtype_inclusion
|
||||||
|
|
||||||
let compunit impl_name impl_sig intf_name intf_sig =
|
let compunit impl_name impl_sig intf_name intf_sig =
|
||||||
try
|
try
|
||||||
signatures Env.initial Subst.identity impl_sig intf_sig
|
signatures Env.initial [] Subst.identity impl_sig intf_sig
|
||||||
with Error reasons ->
|
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 modtypes env mty1 mty2 = modtypes env [] Subst.identity mty1 mty2
|
||||||
let signatures env sig1 sig2 = signatures env Subst.identity sig1 sig2
|
let signatures env sig1 sig2 = signatures env [] Subst.identity sig1 sig2
|
||||||
let type_declarations env id decl1 decl2 =
|
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 *)
|
(* Error report *)
|
||||||
|
|
||||||
|
@ -384,9 +392,65 @@ let include_err ppf = function
|
||||||
| Unbound_modtype_path path ->
|
| Unbound_modtype_path path ->
|
||||||
fprintf ppf "Unbound module type %a" Printtyp.path path
|
fprintf ppf "Unbound module type %a" Printtyp.path path
|
||||||
|
|
||||||
let report_error ppf = function
|
let rec context ppf = function
|
||||||
| [] -> ()
|
Module id :: rem ->
|
||||||
| err :: errs ->
|
fprintf ppf "@[<2>module %a%a@]" ident id args rem
|
||||||
let print_errs ppf errs =
|
| Modtype id :: rem ->
|
||||||
List.iter (fun err -> fprintf ppf "@ %a" include_err err) errs in
|
fprintf ppf "@[<2>module type %a =@ %a@]" ident id context_mty rem
|
||||||
fprintf ppf "@[<v>%a%a@]" include_err err print_errs errs
|
| 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 buffer = ref ""
|
||||||
|
let is_big obj =
|
||||||
|
let size = !Clflags.error_size in
|
||||||
|
size > 0 &&
|
||||||
|
begin
|
||||||
|
if String.length !buffer < size then buffer := String.create size;
|
||||||
|
try ignore (Marshal.to_buffer !buffer 0 size obj []); false
|
||||||
|
with _ -> true
|
||||||
|
end
|
||||||
|
|
||||||
|
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 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
|
||||||
|
|
|
@ -24,7 +24,7 @@ val compunit: string -> signature -> string -> signature -> module_coercion
|
||||||
val type_declarations:
|
val type_declarations:
|
||||||
Env.t -> Ident.t -> type_declaration -> type_declaration -> unit
|
Env.t -> Ident.t -> type_declaration -> type_declaration -> unit
|
||||||
|
|
||||||
type error =
|
type symptom =
|
||||||
Missing_field of Ident.t
|
Missing_field of Ident.t
|
||||||
| Value_descriptions of Ident.t * value_description * value_description
|
| Value_descriptions of Ident.t * value_description * value_description
|
||||||
| Type_declarations of Ident.t * type_declaration
|
| Type_declarations of Ident.t * type_declaration
|
||||||
|
@ -43,6 +43,10 @@ type error =
|
||||||
Ctype.class_match_failure list
|
Ctype.class_match_failure list
|
||||||
| Unbound_modtype_path of Path.t
|
| 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
|
exception Error of error list
|
||||||
|
|
||||||
val report_error: formatter -> error list -> unit
|
val report_error: formatter -> error list -> unit
|
||||||
|
|
|
@ -53,6 +53,7 @@ and no_auto_link = ref false (* -noautolink *)
|
||||||
and dllpaths = ref ([] : string list) (* -dllpath *)
|
and dllpaths = ref ([] : string list) (* -dllpath *)
|
||||||
and make_package = ref false (* -pack *)
|
and make_package = ref false (* -pack *)
|
||||||
and for_package = ref (None: string option) (* -for-pack *)
|
and for_package = ref (None: string option) (* -for-pack *)
|
||||||
|
and error_size = ref 500 (* -error-size *)
|
||||||
let dump_parsetree = ref false (* -dparsetree *)
|
let dump_parsetree = ref false (* -dparsetree *)
|
||||||
and dump_rawlambda = ref false (* -drawlambda *)
|
and dump_rawlambda = ref false (* -drawlambda *)
|
||||||
and dump_lambda = ref false (* -dlambda *)
|
and dump_lambda = ref false (* -dlambda *)
|
||||||
|
|
|
@ -50,6 +50,7 @@ val no_auto_link : bool ref
|
||||||
val dllpaths : string list ref
|
val dllpaths : string list ref
|
||||||
val make_package : bool ref
|
val make_package : bool ref
|
||||||
val for_package : string option ref
|
val for_package : string option ref
|
||||||
|
val error_size : int ref
|
||||||
val dump_parsetree : bool ref
|
val dump_parsetree : bool ref
|
||||||
val dump_rawlambda : bool ref
|
val dump_rawlambda : bool ref
|
||||||
val dump_lambda : bool ref
|
val dump_lambda : bool ref
|
||||||
|
|
Loading…
Reference in New Issue