(**************************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. *) (* *) (* All rights reserved. This file is distributed under the terms of *) (* the GNU Lesser General Public License version 2.1, with the *) (* special exception on linking described in the file LICENSE. *) (* *) (**************************************************************************) (* Inclusion checks for the module language *) open Misc open Typedtree open Types type symptom = Missing_field of Ident.t * Location.t * string (* kind *) | Value_descriptions of Ident.t * value_description * value_description | Type_declarations of Ident.t * type_declaration * type_declaration * Includecore.type_mismatch | Extension_constructors of Ident.t * extension_constructor * extension_constructor * Includecore.extension_constructor_mismatch | Module_types of module_type * module_type | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration | Modtype_permutation of Types.module_type * Typedtree.module_coercion | Interface_mismatch of string * string | Class_type_declarations of Ident.t * class_type_declaration * class_type_declaration * Ctype.class_match_failure list | Class_declarations of Ident.t * class_declaration * class_declaration * Ctype.class_match_failure list | Unbound_modtype_path of Path.t | Unbound_module_path of Path.t | Invalid_module_alias of Path.t type pos = | Module of Ident.t | Modtype of Ident.t | Arg of functor_parameter | Body of functor_parameter type error = pos list * Env.t * symptom exception Error of error list exception Apply_error of Location.t * Path.t * Path.t * error list type mark = | Mark_both | Mark_positive | Mark_negative | Mark_neither let negate_mark = function | Mark_both -> Mark_both | Mark_positive -> Mark_negative | Mark_negative -> Mark_positive | Mark_neither -> Mark_neither let mark_positive = function | Mark_both | Mark_positive -> true | Mark_negative | Mark_neither -> false (* 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 specification x2. If not, Error is raised with a backtrace of the error. *) (* Inclusion between value descriptions *) let value_descriptions ~loc env ~mark cxt subst id vd1 vd2 = Cmt_format.record_value_dependency vd1 vd2; if mark_positive mark then Env.mark_value_used vd1.val_uid; let vd2 = Subst.value_description subst vd2 in try Includecore.value_descriptions ~loc env (Ident.name id) vd1 vd2 with Includecore.Dont_match -> raise(Error[cxt, env, Value_descriptions(id, vd1, vd2)]) (* Inclusion between type declarations *) let type_declarations ~loc env ~mark ?old_env:_ cxt subst id decl1 decl2 = let mark = mark_positive mark in if mark then Env.mark_type_used decl1.type_uid; let decl2 = Subst.type_declaration subst decl2 in match Includecore.type_declarations ~loc env ~mark (Ident.name id) decl1 (Path.Pident id) decl2 with | None -> () | Some err -> raise(Error[cxt, env, Type_declarations(id, decl1, decl2, err)]) (* Inclusion between extension constructors *) let extension_constructors ~loc env ~mark cxt subst id ext1 ext2 = let mark = mark_positive mark in let ext2 = Subst.extension_constructor subst ext2 in match Includecore.extension_constructors ~loc env ~mark id ext1 ext2 with | None -> () | Some err -> raise(Error[cxt, env, Extension_constructors(id, ext1, ext2, err)]) (* Inclusion between class declarations *) let class_type_declarations ~loc ~old_env:_ env cxt subst id decl1 decl2 = let decl2 = Subst.cltype_declaration subst decl2 in match Includeclass.class_type_declarations ~loc env decl1 decl2 with [] -> () | reason -> raise(Error[cxt, env, Class_type_declarations(id, decl1, decl2, reason)]) let class_declarations ~old_env:_ 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[cxt, env, Class_declarations(id, decl1, decl2, reason)]) (* Expand a module type identifier when possible *) exception Dont_match let try_expand_modtype_path env path = try Env.find_modtype_expansion path env with Not_found -> raise Dont_match let expand_module_alias env cxt path = try (Env.find_module path env).md_type with Not_found -> raise(Error[cxt, env, Unbound_module_path path]) (* Extract name, kind and ident from a signature item *) type field_desc = Field_value of string | Field_type of string | Field_exception of string | Field_typext of string | Field_module of string | Field_modtype of string | Field_class of string | Field_classtype of string let kind_of_field_desc = function | Field_value _ -> "value" | Field_type _ -> "type" | Field_exception _ -> "exception" | Field_typext _ -> "extension constructor" | Field_module _ -> "module" | Field_modtype _ -> "module type" | Field_class _ -> "class" | Field_classtype _ -> "class type" (** Map indexed by both field types and names. This avoids name clashes between different sorts of fields such as values and types. *) module FieldMap = Map.Make(struct type t = field_desc let compare = Stdlib.compare end) let item_ident_name = function Sig_value(id, d, _) -> (id, d.val_loc, Field_value(Ident.name id)) | Sig_type(id, d, _, _) -> (id, d.type_loc, Field_type(Ident.name id)) | Sig_typext(id, d, _, _) -> let kind = if Path.same d.ext_type_path Predef.path_exn then Field_exception(Ident.name id) else Field_typext(Ident.name id) in (id, d.ext_loc, kind) | Sig_module(id, _, d, _, _) -> (id, d.md_loc, Field_module(Ident.name id)) | Sig_modtype(id, d, _) -> (id, d.mtd_loc, Field_modtype(Ident.name id)) | Sig_class(id, d, _, _) -> (id, d.cty_loc, Field_class(Ident.name id)) | Sig_class_type(id, d, _, _) -> (id, d.clty_loc, Field_classtype(Ident.name id)) let is_runtime_component = function | Sig_value(_,{val_kind = Val_prim _}, _) | Sig_type(_,_,_,_) | Sig_module(_,Mp_absent,_,_,_) | Sig_modtype(_,_,_) | Sig_class_type(_,_,_,_) -> false | Sig_value(_,_,_) | Sig_typext(_,_,_,_) | Sig_module(_,Mp_present,_,_,_) | Sig_class(_,_,_,_) -> true (* Print a coercion *) let rec print_list pr ppf = function [] -> () | [a] -> pr ppf a | a :: l -> pr ppf a; Format.fprintf ppf ";@ "; print_list pr ppf l let print_list pr ppf l = Format.fprintf ppf "[@[%a@]]" (print_list pr) l let rec print_coercion ppf c = let pr fmt = Format.fprintf ppf fmt in match c with Tcoerce_none -> pr "id" | Tcoerce_structure (fl, nl) -> pr "@[<2>struct@ %a@ %a@]" (print_list print_coercion2) fl (print_list print_coercion3) nl | Tcoerce_functor (inp, out) -> pr "@[<2>functor@ (%a)@ (%a)@]" print_coercion inp print_coercion out | Tcoerce_primitive {pc_desc; pc_env = _; pc_type} -> pr "prim %s@ (%a)" pc_desc.Primitive.prim_name Printtyp.raw_type_expr pc_type | Tcoerce_alias (_, p, c) -> pr "@[<2>alias %a@ (%a)@]" Printtyp.path p print_coercion c and print_coercion2 ppf (n, c) = Format.fprintf ppf "@[%d,@ %a@]" n print_coercion c and print_coercion3 ppf (i, n, c) = Format.fprintf ppf "@[%s, %d,@ %a@]" (Ident.unique_name i) n print_coercion c (* Simplify a structure coercion *) let equal_module_paths env p1 subst p2 = Path.same p1 p2 || Path.same (Env.normalize_module_path None env p1) (Env.normalize_module_path None env (Subst.module_path subst p2)) let equal_modtype_paths env p1 subst p2 = Path.same p1 p2 || Path.same (Env.normalize_modtype_path env p1) (Env.normalize_modtype_path env (Subst.modtype_path subst p2)) let simplify_structure_coercion cc id_pos_list = let rec is_identity_coercion pos = function | [] -> true | (n, c) :: rem -> n = pos && c = Tcoerce_none && is_identity_coercion (pos + 1) rem in if is_identity_coercion 0 cc then Tcoerce_none else Tcoerce_structure (cc, id_pos_list) (* Inclusion between module types. Return the restriction that transforms a value of the smaller type into a value of the bigger type. *) let rec modtypes ~loc env ~mark cxt subst mty1 mty2 = try try_modtypes ~loc env ~mark cxt subst mty1 mty2 with Dont_match -> raise(Error[cxt, env, Module_types(mty1, Subst.modtype Make_local subst mty2)]) | Error reasons as err -> match mty1, mty2 with Mty_alias _, _ | _, Mty_alias _ -> raise err | _ -> raise(Error((cxt, env, Module_types(mty1, Subst.modtype Make_local subst mty2)) :: reasons)) and try_modtypes ~loc env ~mark cxt subst mty1 mty2 = match mty1, mty2 with | (Mty_alias p1, Mty_alias p2) -> if Env.is_functor_arg p2 env then raise (Error[cxt, env, Invalid_module_alias p2]); if not (equal_module_paths env p1 subst p2) then raise Dont_match; Tcoerce_none | (Mty_alias p1, _) -> let p1 = try Env.normalize_module_path (Some Location.none) env p1 with Env.Error (Env.Missing_module (_, _, path)) -> raise (Error[cxt, env, Unbound_module_path path]) in let mty1 = expand_module_alias env cxt p1 in strengthened_modtypes ~loc ~aliasable:true env ~mark cxt subst mty1 p1 mty2 | (Mty_ident p1, Mty_ident p2) -> let p1 = Env.normalize_modtype_path env p1 in let p2 = Env.normalize_modtype_path env (Subst.modtype_path subst p2) in if Path.same p1 p2 then Tcoerce_none else try_modtypes ~loc env ~mark cxt subst (try_expand_modtype_path env p1) (try_expand_modtype_path env p2) | (Mty_ident p1, _) -> let p1 = Env.normalize_modtype_path env p1 in try_modtypes ~loc env ~mark cxt subst (try_expand_modtype_path env p1) mty2 | (_, Mty_ident p2) -> let p2 = Env.normalize_modtype_path env (Subst.modtype_path subst p2) in try_modtypes ~loc env ~mark cxt subst mty1 (try_expand_modtype_path env p2) | (Mty_signature sig1, Mty_signature sig2) -> signatures ~loc env ~mark cxt subst sig1 sig2 | (Mty_functor(Unit, res1), Mty_functor(Unit, res2)) -> begin match modtypes ~loc env ~mark (Body Unit::cxt) subst res1 res2 with | Tcoerce_none -> Tcoerce_none | cc -> Tcoerce_functor (Tcoerce_none, cc) end | (Mty_functor(Named (param1, arg1) as arg, res1), Mty_functor(Named (param2, arg2), res2)) -> let arg2' = Subst.modtype Keep subst arg2 in let cc_arg = modtypes ~loc env ~mark:(negate_mark mark) (Arg arg::cxt) Subst.identity arg2' arg1 in let env, subst = match param1, param2 with | Some p1, Some p2 -> Env.add_module p1 Mp_present arg2' env, Subst.add_module p2 (Path.Pident p1) subst | None, Some p2 -> Env.add_module p2 Mp_present arg2' env, subst | Some p1, None -> Env.add_module p1 Mp_present arg2' env, subst | None, None -> env, subst in let cc_res = modtypes ~loc env ~mark (Body arg::cxt) subst res1 res2 in begin match (cc_arg, cc_res) with (Tcoerce_none, Tcoerce_none) -> Tcoerce_none | _ -> Tcoerce_functor(cc_arg, cc_res) end | (_, _) -> raise Dont_match and strengthened_modtypes ~loc ~aliasable env ~mark cxt subst mty1 path1 mty2 = match mty1, mty2 with | Mty_ident p1, Mty_ident p2 when equal_modtype_paths env p1 subst p2 -> Tcoerce_none | _, _ -> let mty1 = Mtype.strengthen ~aliasable env mty1 path1 in modtypes ~loc env ~mark cxt subst mty1 mty2 and strengthened_module_decl ~loc ~aliasable env ~mark cxt subst md1 path1 md2 = match md1.md_type, md2.md_type with | Mty_ident p1, Mty_ident p2 when equal_modtype_paths env p1 subst p2 -> Tcoerce_none | _, _ -> let md1 = Mtype.strengthen_decl ~aliasable env md1 path1 in modtypes ~loc env ~mark cxt subst md1.md_type md2.md_type (* Inclusion between signatures *) and signatures ~loc env ~mark cxt subst sig1 sig2 = (* Environment used to check inclusion of components *) let new_env = Env.add_signature sig1 (Env.in_signature true env) in (* Keep ids for module aliases *) let (id_pos_list,_) = List.fold_left (fun (l,pos) -> function Sig_module (id, Mp_present, _, _, _) -> ((id,pos,Tcoerce_none)::l , pos+1) | item -> (l, if is_runtime_component item then pos+1 else pos)) ([], 0) sig1 in (* Build a table of the components of sig1, along with their positions. The table is indexed by kind and name of component *) let rec build_component_table pos tbl = function [] -> pos, tbl | (Sig_value (_, _, Hidden) |Sig_type (_, _, _, Hidden) |Sig_typext (_, _, _, Hidden) |Sig_module (_, _, _, _, Hidden) |Sig_modtype (_, _, Hidden) |Sig_class (_, _, _, Hidden) |Sig_class_type (_, _, _, Hidden) ) as item :: rem -> let pos = if is_runtime_component item then pos + 1 else pos in build_component_table pos tbl rem (* do not pair private items. *) | item :: rem -> let (id, _loc, name) = item_ident_name item in let pos, nextpos = if is_runtime_component item then pos, pos + 1 else -1, pos in build_component_table nextpos (FieldMap.add name (id, item, pos) tbl) rem in let len1, comps1 = build_component_table 0 FieldMap.empty sig1 in let len2 = List.fold_left (fun n i -> if is_runtime_component i then n + 1 else n) 0 sig2 in (* Pair each component of sig2 with a component of sig1, identifying the names along the way. Return a coercion list indicating, for all run-time components of sig2, the position of the matching run-time components of sig1 and the coercion to be applied to it. *) let rec pair_components subst paired unpaired = function [] -> begin match unpaired with [] -> let cc = signature_components ~loc env ~mark new_env cxt subst (List.rev paired) in if len1 = len2 then (* see PR#5098 *) simplify_structure_coercion cc id_pos_list else Tcoerce_structure (cc, id_pos_list) | _ -> raise(Error unpaired) end | item2 :: rem -> let (id2, loc, name2) = item_ident_name item2 in let name2, report = match item2, name2 with Sig_type (_, {type_manifest=None}, _, _), Field_type s when Btype.is_row_name s -> (* Do not report in case of failure, as the main type will generate an error *) Field_type (String.sub s 0 (String.length s - 4)), false | _ -> name2, true in begin try let (id1, item1, pos1) = FieldMap.find name2 comps1 in let new_subst = match item2 with Sig_type _ -> Subst.add_type id2 (Path.Pident id1) subst | Sig_module _ -> Subst.add_module id2 (Path.Pident id1) subst | Sig_modtype _ -> Subst.add_modtype id2 (Mty_ident (Path.Pident id1)) subst | Sig_value _ | Sig_typext _ | Sig_class _ | Sig_class_type _ -> subst in pair_components new_subst ((item1, item2, pos1) :: paired) unpaired rem with Not_found -> let unpaired = if report then (cxt, env, Missing_field (id2, loc, kind_of_field_desc name2)) :: unpaired else unpaired in pair_components subst paired unpaired rem end in (* Do the pairing and checking, and return the final coercion *) pair_components subst [] [] sig2 (* Inclusion between signature components *) and signature_components ~loc old_env ~mark env cxt subst paired = let comps_rec rem = signature_components ~loc old_env ~mark env cxt subst rem in match paired with [] -> [] | (Sig_value(id1, valdecl1, _), Sig_value(_id2, valdecl2, _), pos) :: rem -> let cc = value_descriptions ~loc env ~mark cxt subst id1 valdecl1 valdecl2 in begin match valdecl2.val_kind with Val_prim _ -> comps_rec rem | _ -> (pos, cc) :: comps_rec rem end | (Sig_type(id1, tydecl1, _, _), Sig_type(_id2, tydecl2, _, _), _pos) :: rem -> type_declarations ~loc ~old_env env ~mark cxt subst id1 tydecl1 tydecl2; comps_rec rem | (Sig_typext(id1, ext1, _, _), Sig_typext(_id2, ext2, _, _), pos) :: rem -> extension_constructors ~loc env ~mark cxt subst id1 ext1 ext2; (pos, Tcoerce_none) :: comps_rec rem | (Sig_module(id1, pres1, mty1, _, _), Sig_module(_id2, pres2, mty2, _, _), pos) :: rem -> begin let cc = module_declarations ~loc env ~mark cxt subst id1 mty1 mty2 in let rem = comps_rec rem in match pres1, pres2, mty1.md_type with | Mp_present, Mp_present, _ -> (pos, cc) :: rem | _, Mp_absent, _ -> rem | Mp_absent, Mp_present, Mty_alias p1 -> (pos, Tcoerce_alias (env, p1, cc)) :: rem | Mp_absent, Mp_present, _ -> assert false end | (Sig_modtype(id1, info1, _), Sig_modtype(_id2, info2, _), _pos) :: rem -> modtype_infos ~loc env ~mark cxt subst id1 info1 info2; comps_rec rem | (Sig_class(id1, decl1, _, _), Sig_class(_id2, decl2, _, _), pos) :: rem -> class_declarations ~old_env env cxt subst id1 decl1 decl2; (pos, Tcoerce_none) :: comps_rec rem | (Sig_class_type(id1, info1, _, _), Sig_class_type(_id2, info2, _, _), _pos) :: rem -> class_type_declarations ~loc ~old_env env cxt subst id1 info1 info2; comps_rec rem | _ -> assert false and module_declarations ~loc env ~mark cxt subst id1 md1 md2 = Builtin_attributes.check_alerts_inclusion ~def:md1.md_loc ~use:md2.md_loc loc md1.md_attributes md2.md_attributes (Ident.name id1); let p1 = Path.Pident id1 in if mark_positive mark then Env.mark_module_used md1.md_uid; strengthened_modtypes ~loc ~aliasable:true env ~mark (Module id1::cxt) subst md1.md_type p1 md2.md_type (* Inclusion between module type specifications *) and modtype_infos ~loc env ~mark cxt subst id info1 info2 = Builtin_attributes.check_alerts_inclusion ~def:info1.mtd_loc ~use:info2.mtd_loc loc info1.mtd_attributes info2.mtd_attributes (Ident.name id); let info2 = Subst.modtype_declaration Keep subst info2 in let cxt' = Modtype id :: cxt in try match (info1.mtd_type, info2.mtd_type) with (None, None) -> () | (Some _, None) -> () | (Some mty1, Some mty2) -> check_modtype_equiv ~loc env ~mark cxt' mty1 mty2 | (None, Some mty2) -> check_modtype_equiv ~loc env ~mark cxt' (Mty_ident(Path.Pident id)) mty2 with Error reasons -> raise(Error((cxt, env, Modtype_infos(id, info1, info2)) :: reasons)) and check_modtype_equiv ~loc env ~mark cxt mty1 mty2 = match (modtypes ~loc env ~mark cxt Subst.identity mty1 mty2, modtypes ~loc env ~mark:(negate_mark mark) cxt Subst.identity mty2 mty1) with (Tcoerce_none, Tcoerce_none) -> () | (c1, _c2) -> (* Format.eprintf "@[c1 = %a@ c2 = %a@]@." print_coercion _c1 print_coercion _c2; *) raise(Error [cxt, env, Modtype_permutation (mty1, c1)]) (* Simplified inclusion check between module types (for Env) *) let can_alias env path = let rec no_apply = function | Path.Pident _ -> true | Path.Pdot(p, _) -> no_apply p | Path.Papply _ -> false in no_apply path && not (Env.is_functor_arg path env) let check_modtype_inclusion ~loc env mty1 path1 mty2 = let aliasable = can_alias env path1 in ignore (strengthened_modtypes ~loc ~aliasable env ~mark:Mark_both [] Subst.identity mty1 path1 mty2) let () = Env.check_functor_application := (fun ~errors ~loc env mty1 path1 mty2 path2 -> try check_modtype_inclusion ~loc env mty1 path1 mty2 with Error errs -> if errors then raise (Apply_error(loc, path1, path2, errs)) else raise Not_found) (* Check that an implementation of a compilation unit meets its interface. *) let compunit env ~mark impl_name impl_sig intf_name intf_sig = try signatures ~loc:(Location.in_file impl_name) env ~mark [] Subst.identity impl_sig intf_sig with Error reasons -> raise(Error(([], Env.empty,Interface_mismatch(impl_name, intf_name)) :: reasons)) (* Hide the context and substitution parameters to the outside world *) let modtypes ~loc env ~mark mty1 mty2 = modtypes ~loc env ~mark [] Subst.identity mty1 mty2 let signatures env ~mark sig1 sig2 = signatures ~loc:Location.none env ~mark [] Subst.identity sig1 sig2 let type_declarations ~loc env ~mark id decl1 decl2 = type_declarations ~loc env ~mark [] Subst.identity id decl1 decl2 let strengthened_module_decl ~loc ~aliasable env ~mark md1 path1 md2 = strengthened_module_decl ~loc ~aliasable env ~mark [] Subst.identity md1 path1 md2 (* let modtypes env m1 m2 = let c = modtypes env m1 m2 in Format.eprintf "@[<2>modtypes@ %a@ %a =@ %a@]@." Printtyp.modtype m1 Printtyp.modtype m2 print_coercion c; c *) (* Error report *) module Illegal_permutation = struct (** Extraction of information in case of illegal permutation in a module type *) (** When examining coercions, we only have runtime component indices, we use thus a limited version of {!pos}. *) type coerce_pos = | Item of int | InArg | InBody let either f x g y = match f x with | None -> g y | Some _ as v -> v (** We extract a lone transposition from a full tree of permutations. *) let rec transposition_under path = function | Tcoerce_structure(c,_) -> either (not_fixpoint path 0) c (first_non_id path 0) c | Tcoerce_functor(arg,res) -> either (transposition_under (InArg::path)) arg (transposition_under (InBody::path)) res | Tcoerce_none -> None | Tcoerce_alias _ | Tcoerce_primitive _ -> (* these coercions are not inversible, and raise an error earlier when checking for module type equivalence *) assert false (* we search the first point which is not invariant at the current level *) and not_fixpoint path pos = function | [] -> None | (n, _) :: q -> if n = pos then not_fixpoint path (pos+1) q else Some(List.rev path, pos, n) (* we search the first item with a non-identity inner coercion *) and first_non_id path pos = function | [] -> None | (_,Tcoerce_none) :: q -> first_non_id path (pos + 1) q | (_,c) :: q -> either (transposition_under (Item pos :: path)) c (first_non_id path (pos + 1)) q let transposition c = match transposition_under [] c with | None -> raise Not_found | Some x -> x let rec runtime_item k = function | [] -> raise Not_found | item :: q -> if not(is_runtime_component item) then runtime_item k q else if k = 0 then item else runtime_item (k-1) q (* Find module type at position [path] and convert the [coerce_pos] path to a [pos] path *) let rec find env ctx path mt = match mt, path with | (Mty_ident p | Mty_alias p), _ -> begin match (Env.find_modtype p env).mtd_type with | None -> raise Not_found | Some mt -> find env ctx path mt end | Mty_signature s , [] -> List.rev ctx, s | Mty_signature s, Item k :: q -> begin match runtime_item k s with | Sig_module (id, _, md,_,_) -> find env (Module id :: ctx) q md.md_type | _ -> raise Not_found end | Mty_functor(Named (_,mt) as arg,_), InArg :: q -> find env (Arg arg :: ctx) q mt | Mty_functor(arg, mt), InBody :: q -> find env (Body arg :: ctx) q mt | _ -> raise Not_found let find env path mt = find env [] path mt let item mt k = item_ident_name (runtime_item k mt) let pp_item ppf (id,_,kind) = Format.fprintf ppf "%s %S" (kind_of_field_desc kind) (Ident.name id) let pp ctx_printer env ppf (mty,c) = try let p, k, l = transposition c in let ctx, mt = find env p mty in Format.fprintf ppf "@[Illegal permutation of runtime components in a module type.@ \ @[For example,@ %a@[the %a@ and the %a are not in the same order@ \ in the expected and actual module types.@]@]" ctx_printer ctx pp_item (item mt k) pp_item (item mt l) with Not_found -> (* this should not happen *) Format.fprintf ppf "Illegal permutation of runtime components in a module type." end open Format let show_loc msg ppf loc = let pos = loc.Location.loc_start in if List.mem pos.Lexing.pos_fname [""; "_none_"; "//toplevel//"] then () else fprintf ppf "@\n@[<2>%a:@ %s@]" Location.print_loc loc msg let show_locs ppf (loc1, loc2) = show_loc "Expected declaration" ppf loc2; show_loc "Actual declaration" ppf loc1 let path_of_context = function Module id :: rem -> let rec subm path = function | [] -> path | Module id :: rem -> subm (Path.Pdot (path, Ident.name id)) rem | _ -> assert false in subm (Path.Pident id) rem | _ -> assert false let rec context ppf = function Module id :: rem -> fprintf ppf "@[<2>module %a%a@]" Printtyp.ident id args rem | Modtype id :: rem -> fprintf ppf "@[<2>module type %a =@ %a@]" Printtyp.ident id context_mty rem | Body x :: rem -> fprintf ppf "functor (%s) ->@ %a" (argname x) context_mty rem | Arg x :: rem -> fprintf ppf "functor (%s : %a) -> ..." (argname x) context_mty rem | [] -> fprintf ppf "" 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 "(%s)%a" (argname x) args rem | Arg x :: rem -> fprintf ppf "(%s :@ %a) : ..." (argname x) context_mty rem | cxt -> fprintf ppf " :@ %a" context_mty cxt and argname = function | Unit -> "" | Named (None, _) -> "_" | Named (Some id, _) -> Ident.name id let alt_context ppf cxt = if cxt = [] then () else if List.for_all (function Module _ -> true | _ -> false) cxt then fprintf ppf "in module %a,@ " Printtyp.path (path_of_context cxt) else fprintf ppf "@[at position@ %a,@]@ " context cxt let context ppf cxt = if cxt = [] then () else if List.for_all (function Module _ -> true | _ -> false) cxt then fprintf ppf "In module %a:@ " Printtyp.path (path_of_context cxt) else fprintf ppf "@[At position@ %a@]@ " context cxt let include_err env ppf = function | Missing_field (id, loc, kind) -> fprintf ppf "The %s `%a' is required but not provided" kind Printtyp.ident id; show_loc "Expected declaration" ppf loc | Value_descriptions(id, d1, d2) -> fprintf ppf "@[Values do not match:@ %a@;<1 -2>is not included in@ %a@]" !Oprint.out_sig_item (Printtyp.tree_of_value_description id d1) !Oprint.out_sig_item (Printtyp.tree_of_value_description id d2); show_locs ppf (d1.val_loc, d2.val_loc) | Type_declarations(id, d1, d2, err) -> fprintf ppf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a@]" "Type declarations do not match" !Oprint.out_sig_item (Printtyp.tree_of_type_declaration id d1 Trec_first) "is not included in" !Oprint.out_sig_item (Printtyp.tree_of_type_declaration id d2 Trec_first) (Includecore.report_type_mismatch "the first" "the second" "declaration") err show_locs (d1.type_loc, d2.type_loc) | Extension_constructors(id, x1, x2, err) -> fprintf ppf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]@ %a%a@]" "Extension declarations do not match" !Oprint.out_sig_item (Printtyp.tree_of_extension_constructor id x1 Text_first) "is not included in" !Oprint.out_sig_item (Printtyp.tree_of_extension_constructor id x2 Text_first) (Includecore.report_extension_constructor_mismatch "the first" "the second" "declaration") err show_locs (x1.ext_loc, x2.ext_loc) | Module_types(mty1, mty2)-> fprintf ppf "@[Modules do not match:@ \ %a@;<1 -2>is not included in@ %a@]" !Oprint.out_module_type (Printtyp.tree_of_modtype mty1) !Oprint.out_module_type (Printtyp.tree_of_modtype mty2) | Modtype_infos(id, d1, d2) -> fprintf ppf "@[Module type declarations do not match:@ \ %a@;<1 -2>does not match@ %a@]" !Oprint.out_sig_item (Printtyp.tree_of_modtype_declaration id d1) !Oprint.out_sig_item (Printtyp.tree_of_modtype_declaration id d2) | Modtype_permutation (mty,c) -> Illegal_permutation.pp alt_context env ppf (mty,c) | Interface_mismatch(impl_name, intf_name) -> fprintf ppf "@[The implementation %s@ does not match the interface %s:" impl_name intf_name | Class_type_declarations(id, d1, d2, reason) -> fprintf ppf "@[Class type declarations do not match:@ \ %a@;<1 -2>does not match@ %a@]@ %a" !Oprint.out_sig_item (Printtyp.tree_of_cltype_declaration id d1 Trec_first) !Oprint.out_sig_item (Printtyp.tree_of_cltype_declaration id d2 Trec_first) Includeclass.report_error reason | Class_declarations(id, d1, d2, reason) -> fprintf ppf "@[Class declarations do not match:@ \ %a@;<1 -2>does not match@ %a@]@ %a" !Oprint.out_sig_item (Printtyp.tree_of_class_declaration id d1 Trec_first) !Oprint.out_sig_item (Printtyp.tree_of_class_declaration id d2 Trec_first) Includeclass.report_error reason | Unbound_modtype_path path -> fprintf ppf "Unbound module type %a" Printtyp.path path | Unbound_module_path path -> fprintf ppf "Unbound module %a" Printtyp.path path | Invalid_module_alias path -> fprintf ppf "Module %a cannot be aliased" Printtyp.path path let include_err ppf (cxt, env, err) = Printtyp.wrap_printing_env ~error:true env (fun () -> fprintf ppf "@[%a%a@]" context (List.rev cxt) (include_err env) err) let buffer = ref Bytes.empty let is_big obj = let size = !Clflags.error_size in size > 0 && begin if Bytes.length !buffer < size then buffer := Bytes.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 (_,_,obj as err) = if not (is_big obj) 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 Printtyp.Conflicts.reset(); fprintf ppf "@[%a%a%t@]" print_errs errs include_err err Printtyp.Conflicts.print_explanations let report_apply_error p1 p2 ppf errs = fprintf ppf "@[The type of %a does not match %a's parameter@ %a@]" Printtyp.path p1 Printtyp.path p2 report_error errs (* We could do a better job to split the individual error items as sub-messages of the main interface mismatch on the whole unit. *) let () = Location.register_error_of_exn (function | Error err -> Some (Location.error_of_printer_file report_error err) | Apply_error(loc, p1, p2, err) -> Some (Location.error_of_printer ~loc (report_apply_error p1 p2) err) | _ -> None )