diff --git a/boot/ocamlc b/boot/ocamlc index 529f035f3d..c652ff793a 100755 Binary files a/boot/ocamlc and b/boot/ocamlc differ diff --git a/boot/ocamldep b/boot/ocamldep index 7a00e4d253..b9cb11cd0c 100755 Binary files a/boot/ocamldep and b/boot/ocamldep differ diff --git a/boot/ocamllex b/boot/ocamllex index fa5aada9c1..de1904f606 100755 Binary files a/boot/ocamllex and b/boot/ocamllex differ diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index d3a04c23a1..66fed87092 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -216,7 +216,7 @@ let init_shape modl = init_shape_struct (Env.add_type ~check:false id tdecl env) rem | Sig_typext(id, ext, _) :: rem -> raise Not_found - | Sig_module(id, md, _) :: rem -> + | Sig_module(id, md, _, _) :: rem -> init_shape_mod env md.md_type :: init_shape_struct (Env.add_module_declaration id md env) rem | Sig_modtype(id, minfo) :: rem -> @@ -226,6 +226,8 @@ let init_shape modl = :: init_shape_struct env rem | Sig_class_type(id, ctyp, _) :: rem -> init_shape_struct env rem + | Sig_implicit _ :: rem -> + init_shape_struct env rem in try Some(undefined_location modl.mod_loc, @@ -316,7 +318,7 @@ let rec bound_value_identifiers = function | Sig_value(id, {val_kind = Val_reg}) :: rem -> id :: bound_value_identifiers rem | Sig_typext(id, ext, _) :: rem -> id :: bound_value_identifiers rem - | Sig_module(id, mty, _) :: rem -> id :: bound_value_identifiers rem + | Sig_module(id, mty, _, _) :: rem -> id :: bound_value_identifiers rem | Sig_class(id, decl, _) :: rem -> id :: bound_value_identifiers rem | _ :: rem -> bound_value_identifiers rem @@ -396,8 +398,8 @@ and transl_structure fields cc rootpath = function fatal_error "Translmod.transl_structure" end | item :: rem -> - match item.str_desc with - | Tstr_eval (expr, _) -> + match item.str_desc with + | Tstr_eval (expr, _) -> Lsequence(transl_exp expr, transl_structure fields cc rootpath rem) | Tstr_value(rec_flag, pat_expr_list) -> let ext_fields = rev_let_bound_idents pat_expr_list @ fields in @@ -456,6 +458,7 @@ and transl_structure fields cc rootpath = function | Tstr_modtype _ | Tstr_open _ | Tstr_class_type _ + | Tstr_implicit _ | Tstr_attribute _ -> transl_structure fields cc rootpath rem @@ -506,7 +509,8 @@ let rec defined_idents = function | Tstr_class_type cl_list -> defined_idents rem | Tstr_include incl -> bound_value_identifiers incl.incl_type @ defined_idents rem - | Tstr_attribute _ -> defined_idents rem + | Tstr_attribute _ | Tstr_implicit _ -> + defined_idents rem (* second level idents (module M = struct ... let id = ... end), and all sub-levels idents *) @@ -530,6 +534,7 @@ let rec more_idents = function all_idents str.str_items @ more_idents rem | Tstr_module _ -> more_idents rem | Tstr_attribute _ -> more_idents rem + | Tstr_implicit _ -> more_idents rem and all_idents = function [] -> [] @@ -557,6 +562,7 @@ and all_idents = function mb_id :: all_idents str.str_items @ all_idents rem | Tstr_module mb -> mb.mb_id :: all_idents rem | Tstr_attribute _ -> all_idents rem + | Tstr_implicit _ -> all_idents rem (* A variant of transl_structure used to compile toplevel structure definitions @@ -673,6 +679,7 @@ let transl_store_structure glob map prims str = | Tstr_modtype _ | Tstr_open _ | Tstr_class_type _ + | Tstr_implicit _ | Tstr_attribute _ -> transl_store rootpath subst rem @@ -870,6 +877,7 @@ let transl_toplevel_item item = | Tstr_primitive _ | Tstr_type _ | Tstr_class_type _ + | Tstr_implicit _ | Tstr_attribute _ -> lambda_unit diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml index f85f58602b..ab3276ae40 100644 --- a/ocamldoc/odoc_ast.ml +++ b/ocamldoc/odoc_ast.ml @@ -114,6 +114,7 @@ module Typedtree_search = Hashtbl.add table (P (Name.from_ident vd.val_id)) tt | Typedtree.Tstr_open _ -> () | Typedtree.Tstr_include _ -> () + | Typedtree.Tstr_implicit _ -> () | Typedtree.Tstr_eval _ -> () | Typedtree.Tstr_attribute _ -> () @@ -951,7 +952,7 @@ module Analyser = let f = match ele with Element_module m -> (function - Types.Sig_module (ident,md,_) -> + Types.Sig_module (ident,md,_,_) -> let n1 = Name.simple m.m_name and n2 = Ident.name ident in ( @@ -1088,6 +1089,7 @@ module Analyser = (* don't care *) (0, env, []) | Parsetree.Pstr_attribute _ + | Parsetree.Pstr_implicit _ | Parsetree.Pstr_extension _ -> (0, env, []) | Parsetree.Pstr_value (rec_flag, pat_exp_list) -> diff --git a/ocamldoc/odoc_env.ml b/ocamldoc/odoc_env.ml index 83f59677f3..985682773d 100644 --- a/ocamldoc/odoc_env.ml +++ b/ocamldoc/odoc_env.ml @@ -53,7 +53,7 @@ let rec add_signature env root ?rel signat = Types.Sig_value (ident, _) -> { env with env_values = (rel_name ident, qualify ident) :: env.env_values } | Types.Sig_type (ident,_,_) -> { env with env_types = (rel_name ident, qualify ident) :: env.env_types } | Types.Sig_typext (ident, _, _) -> { env with env_extensions = (rel_name ident, qualify ident) :: env.env_extensions } - | Types.Sig_module (ident, md, _) -> + | Types.Sig_module (ident, md, _, _) -> let env2 = match md.Types.md_type with (* A VOIR : le cas ou c'est un identificateur, dans ce cas on n'a pas de signature *) Types.Mty_signature s -> add_signature env (qualify ident) ~rel: (rel_name ident) s @@ -74,6 +74,7 @@ let rec add_signature env root ?rel signat = { env2 with env_module_types = (rel_name ident, qualify ident) :: env2.env_module_types } | Types.Sig_class (ident, _, _) -> { env with env_classes = (rel_name ident, qualify ident) :: env.env_classes } | Types.Sig_class_type (ident, _, _) -> { env with env_class_types = (rel_name ident, qualify ident) :: env.env_class_types } + | Types.Sig_implicit (path,arity) -> env in List.fold_left f env signat diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml index f03919e670..9a0332fb7f 100644 --- a/ocamldoc/odoc_sig.ml +++ b/ocamldoc/odoc_sig.ml @@ -56,10 +56,12 @@ module Signature_search = Hashtbl.add table (C (Name.from_ident ident)) signat | Types.Sig_class_type (ident, _, _) -> Hashtbl.add table (CT (Name.from_ident ident)) signat - | Types.Sig_module (ident, _, _) -> + | Types.Sig_module (ident, _, _, _) -> Hashtbl.add table (M (Name.from_ident ident)) signat | Types.Sig_modtype (ident,_) -> Hashtbl.add table (MT (Name.from_ident ident)) signat + | Types.Sig_implicit _ -> + () let table signat = let t = Hashtbl.create 13 in @@ -93,7 +95,7 @@ module Signature_search = let search_module table name = match Hashtbl.find table (M name) with - | (Types.Sig_module (ident, md, _)) -> md.Types.md_type + | (Types.Sig_module (ident, md, _, _)) -> md.Types.md_type | _ -> assert false let search_module_type table name = @@ -327,6 +329,7 @@ module Analyser = | Parsetree.Psig_exception _ | Parsetree.Psig_open _ | Parsetree.Psig_include _ + | Parsetree.Psig_implicit _ | Parsetree.Psig_class _ | Parsetree.Psig_class_type _ as tp -> take_item tp | Parsetree.Psig_type types -> @@ -1186,7 +1189,7 @@ module Analyser = f ~first: true 0 pos_start_ele class_type_declaration_list in (maybe_more, new_env, eles) - | Parsetree.Psig_attribute _ + | Parsetree.Psig_attribute _ | Parsetree.Psig_implicit _ | Parsetree.Psig_extension _ -> (0, env, []) diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml index 0cfc4a050b..414537d9ca 100644 --- a/parsing/ast_helper.ml +++ b/parsing/ast_helper.ml @@ -114,6 +114,7 @@ module Exp = struct let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b)) let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a) let open_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_open (a, b, c)) + let implicit_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_implicit (a, b)) let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a) let case lhs ?guard rhs = @@ -165,6 +166,7 @@ module Sig = struct let rec_module ?loc a = mk ?loc (Psig_recmodule a) let modtype ?loc a = mk ?loc (Psig_modtype a) let open_ ?loc a = mk ?loc (Psig_open a) + let implicit_ ?loc a = mk ?loc (Psig_implicit a) let include_ ?loc a = mk ?loc (Psig_include a) let class_ ?loc a = mk ?loc (Psig_class a) let class_type ?loc a = mk ?loc (Psig_class_type a) @@ -185,6 +187,7 @@ module Str = struct let rec_module ?loc a = mk ?loc (Pstr_recmodule a) let modtype ?loc a = mk ?loc (Pstr_modtype a) let open_ ?loc a = mk ?loc (Pstr_open a) + let implicit_ ?loc a = mk ?loc (Pstr_implicit a) let class_ ?loc a = mk ?loc (Pstr_class a) let class_type ?loc a = mk ?loc (Pstr_class_type a) let include_ ?loc a = mk ?loc (Pstr_include a) @@ -318,10 +321,21 @@ module Opn = struct } end +module Imp = struct + let mk ?(loc = !default_loc) ?(attrs = []) kind lid = + { + pimp_lid = lid; + pimp_kind = kind; + pimp_loc = loc; + pimp_attributes = attrs; + } +end + module Incl = struct - let mk ?(loc = !default_loc) ?(attrs = []) mexpr = + let mk ?(loc = !default_loc) ?(attrs = []) ?(flag = Include_all) mexpr = { pincl_mod = mexpr; + pincl_flag = flag; pincl_loc = loc; pincl_attributes = attrs; } diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli index 7765f54044..f07a8813e4 100644 --- a/parsing/ast_helper.mli +++ b/parsing/ast_helper.mli @@ -138,6 +138,8 @@ module Exp: val newtype: ?loc:loc -> ?attrs:attrs -> string -> expression -> expression val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression val open_: ?loc:loc -> ?attrs:attrs -> open_flag -> lid -> expression -> expression + val implicit_: + ?loc:loc -> ?attrs:attrs -> implicit_description -> expression -> expression val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression val case: pattern -> ?guard:expression -> expression -> case @@ -217,6 +219,7 @@ module Sig: val rec_module: ?loc:loc -> module_declaration list -> signature_item val modtype: ?loc:loc -> module_type_declaration -> signature_item val open_: ?loc:loc -> open_description -> signature_item + val implicit_: ?loc:loc -> implicit_description -> signature_item val include_: ?loc:loc -> include_description -> signature_item val class_: ?loc:loc -> class_description list -> signature_item val class_type: ?loc:loc -> class_type_declaration list -> signature_item @@ -239,6 +242,7 @@ module Str: val rec_module: ?loc:loc -> module_binding list -> structure_item val modtype: ?loc:loc -> module_type_declaration -> structure_item val open_: ?loc:loc -> open_description -> structure_item + val implicit_: ?loc:loc -> implicit_description -> structure_item val class_: ?loc:loc -> class_declaration list -> structure_item val class_type: ?loc:loc -> class_type_declaration list -> structure_item val include_: ?loc:loc -> include_declaration -> structure_item @@ -270,10 +274,17 @@ module Opn: val mk: ?loc: loc -> ?attrs:attrs -> ?flag:open_flag -> lid -> open_description end +(* Implicit bindings *) +module Imp: + sig + val mk: ?loc: loc -> ?attrs:attrs -> implicit_kind -> lid -> implicit_description + end + (* Includes *) module Incl: sig - val mk: ?loc: loc -> ?attrs:attrs -> 'a -> 'a include_infos + val mk: + ?loc: loc -> ?attrs:attrs -> ?flag:include_flag -> 'a -> 'a include_infos end (** Value bindings *) diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index 2ce345d25d..5c7a65fff4 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -47,6 +47,7 @@ type mapper = { -> extension_constructor; include_declaration: mapper -> include_declaration -> include_declaration; include_description: mapper -> include_description -> include_description; + implicit_description: mapper -> implicit_description -> implicit_description; label_declaration: mapper -> label_declaration -> label_declaration; location: mapper -> Location.t -> Location.t; module_binding: mapper -> module_binding -> module_binding; @@ -259,6 +260,8 @@ module MT = struct | Psig_extension (x, attrs) -> extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) | Psig_attribute x -> attribute ~loc (sub.attribute sub x) + | Psig_implicit x -> implicit_ ~loc (sub.implicit_description sub x) + end @@ -315,6 +318,7 @@ module M = struct | Pstr_extension (x, attrs) -> extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) | Pstr_attribute x -> attribute ~loc (sub.attribute sub x) + | Pstr_implicit x -> implicit_ ~loc (sub.implicit_description sub x) end module E = struct @@ -386,6 +390,7 @@ module E = struct | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) | Pexp_open (ovf, lid, e) -> open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e) + | Pexp_implicit (imp, e) -> implicit_ ~loc ~attrs imp e | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x) end @@ -565,19 +570,27 @@ let default_mapper = include_description = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> + (fun this {pincl_mod; pincl_flag; pincl_attributes; pincl_loc} -> Incl.mk (this.module_type this pincl_mod) + ~flag:pincl_flag ~loc:(this.location this pincl_loc) ~attrs:(this.attributes this pincl_attributes) ); include_declaration = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> + (fun this {pincl_mod; pincl_flag; pincl_attributes; pincl_loc} -> Incl.mk (this.module_expr this pincl_mod) + ~flag:pincl_flag ~loc:(this.location this pincl_loc) ~attrs:(this.attributes this pincl_attributes) ); + implicit_description = + (fun this {pimp_lid; pimp_kind; pimp_attributes; pimp_loc} -> + Imp.mk pimp_kind (map_loc this pimp_lid) + ~loc:(this.location this pimp_loc) + ~attrs:(this.attributes this pimp_attributes) + ); value_binding = (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> diff --git a/parsing/ast_mapper.mli b/parsing/ast_mapper.mli index 786c37d6be..37e130cb66 100644 --- a/parsing/ast_mapper.mli +++ b/parsing/ast_mapper.mli @@ -39,6 +39,7 @@ type mapper = { -> extension_constructor; include_declaration: mapper -> include_declaration -> include_declaration; include_description: mapper -> include_description -> include_description; + implicit_description: mapper -> implicit_description -> implicit_description; label_declaration: mapper -> label_declaration -> label_declaration; location: mapper -> Location.t -> Location.t; module_binding: mapper -> module_binding -> module_binding; diff --git a/parsing/asttypes.mli b/parsing/asttypes.mli index 787095bcc7..8dfd380ce3 100644 --- a/parsing/asttypes.mli +++ b/parsing/asttypes.mli @@ -35,6 +35,8 @@ type override_flag = Override | Fresh type open_flag = Open_all of override_flag | Open_implicit +type include_flag = Include_all | Include_implicit + type closed_flag = Closed | Open type implicit_flag = Nonimplicit | Implicit diff --git a/parsing/lexer.mll b/parsing/lexer.mll index b108113fa4..b93a661531 100644 --- a/parsing/lexer.mll +++ b/parsing/lexer.mll @@ -45,6 +45,7 @@ let keyword_table = "else", ELSE; "end", END; "exception", EXCEPTION; + "explicit", EXPLICIT; "external", EXTERNAL; "false", FALSE; "for", FOR; @@ -52,6 +53,7 @@ let keyword_table = "function", FUNCTION; "functor", FUNCTOR; "if", IF; + "implicit", IMPLICIT; "in", IN; "include", INCLUDE; "inherit", INHERIT; @@ -61,7 +63,6 @@ let keyword_table = "match", MATCH; "method", METHOD; "module", MODULE; - "implicit", IMPLICIT; "mutable", MUTABLE; "new", NEW; "object", OBJECT; diff --git a/parsing/longident.ml b/parsing/longident.ml index 4e755e9bc9..9b7b87c87b 100644 --- a/parsing/longident.ml +++ b/parsing/longident.ml @@ -39,3 +39,11 @@ let parse s = [] -> Lident "" (* should not happen, but don't put assert false so as not to crash the toplevel (see Genprintval) *) | hd :: tl -> List.fold_left (fun p s -> Ldot(p, s)) (Lident hd) tl + +let rec to_string = function + | Lident s -> s + | Ldot (t,s) -> to_string t ^ "." ^ s + | Lapply (t1,t2, Asttypes.Nonimplicit) -> + to_string t1 ^ "(" ^ to_string t2 ^ ")" + | Lapply (t1,t2, Asttypes.Implicit) -> + to_string t1 ^ "{" ^ to_string t2 ^ "}" diff --git a/parsing/longident.mli b/parsing/longident.mli index 50fd5bacc0..968cab4ec7 100644 --- a/parsing/longident.mli +++ b/parsing/longident.mli @@ -20,3 +20,5 @@ type t = val flatten: t -> string list val last: t -> string val parse: string -> t + +val to_string: t -> string diff --git a/parsing/parser.mly b/parsing/parser.mly index 9df56c2e34..1d079f62ae 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -326,6 +326,7 @@ let mkctf_attrs d attrs = %token EOF %token EQUAL %token EXCEPTION +%token EXPLICIT %token EXTERNAL %token FALSE %token FLOAT @@ -670,12 +671,14 @@ structure_item: { mkstr(Pstr_modtype (Mtd.mk (mkrhs $3 3) ~typ:$5 ~attrs:$6 ~loc:(symbol_rloc()))) } | open_statement { mkstr(Pstr_open $1) } + | implicit_statement { mkstr(Pstr_implicit $1) } | CLASS class_declarations { mkstr(Pstr_class (List.rev $2)) } | CLASS TYPE class_type_declarations { mkstr(Pstr_class_type (List.rev $3)) } - | INCLUDE module_expr post_item_attributes - { mkstr(Pstr_include (Incl.mk $2 ~attrs:$3 ~loc:(symbol_rloc()))) } + | INCLUDE include_flag module_expr post_item_attributes + { mkstr(Pstr_include + (Incl.mk $3 ~flag:$2 ~attrs:$4 ~loc:(symbol_rloc()))) } | item_extension post_item_attributes { mkstr(Pstr_extension ($1, $2)) } | floating_attribute @@ -705,6 +708,12 @@ module_binding: { Mb.mk (mkrhs $3 3) $4 ~implicit_:Implicit ~attrs:$5 ~loc:(symbol_rloc ()) } ; +implicit_statement: + | IMPLICIT mod_longident post_item_attributes + { Imp.mk Pimp_implicit (mkrhs $2 2) ~attrs:$3 ~loc:(symbol_rloc()) } + | EXPLICIT mod_longident post_item_attributes + { Imp.mk Pimp_explicit (mkrhs $2 2) ~attrs:$3 ~loc:(symbol_rloc()) } +; /* Module types */ @@ -783,8 +792,11 @@ signature_item: ~attrs:$6)) } | open_statement { mksig(Psig_open $1) } - | INCLUDE module_type post_item_attributes %prec below_WITH - { mksig(Psig_include (Incl.mk $2 ~attrs:$3 ~loc:(symbol_rloc()))) } + | implicit_statement + { mksig(Psig_implicit $1) } + | INCLUDE include_flag module_type post_item_attributes %prec below_WITH + { mksig(Psig_include + (Incl.mk $3 ~flag:$2 ~attrs:$4 ~loc:(symbol_rloc()))) } | CLASS class_descriptions { mksig(Psig_class (List.rev $2)) } | CLASS TYPE class_type_declarations @@ -1120,6 +1132,12 @@ expr: { mkexp (Pexp_letmodule($2, $4)) (* FIXME: no attributes *) } | LET OPEN open_flag ext_attributes mod_longident IN seq_expr { mkexp_attrs (Pexp_open($3, mkrhs $5 5, $7)) $4 } + | LET IMPLICIT ext_attributes mod_longident IN seq_expr + { mkexp_attrs + (Pexp_implicit (Imp.mk Pimp_implicit (mkrhs $4 4), $6)) $3 } + | LET EXPLICIT ext_attributes mod_longident IN seq_expr + { mkexp_attrs + (Pexp_implicit (Imp.mk Pimp_explicit (mkrhs $4 4), $6)) $3 } | FUNCTION ext_attributes opt_bar match_cases { mkexp_attrs (Pexp_function(List.rev $4)) $2 } | FUN ext_attributes labeled_simple_pattern fun_def @@ -2132,6 +2150,10 @@ open_flag: | IMPLICIT { Open_implicit } | override_flag { Open_all $1 } ; +include_flag: + | /* empty */ { Include_all } + | IMPLICIT { Include_implicit } +; override_flag: /* empty */ { Fresh } | BANG { Override } diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index 7f7cb6bbff..561c702584 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -331,6 +331,7 @@ and expression_desc = let! open M in E let open implicit M in E *) + | Pexp_implicit of implicit_description * expression | Pexp_extension of extension (* [%id] *) @@ -681,6 +682,8 @@ and signature_item_desc = (* [@@@id] *) | Psig_extension of extension * attributes (* [%%id] *) + | Psig_implicit of implicit_description + (* implicit Path *) and module_declaration = { @@ -715,9 +718,22 @@ and open_description = open X - popen_override = Fresh *) +and implicit_description = + { + pimp_lid: Longident.t loc; + pimp_kind: implicit_kind; + pimp_loc: Location.t; + pimp_attributes: attributes; + } + +and implicit_kind = + | Pimp_implicit + | Pimp_explicit + and 'a include_infos = { pincl_mod: 'a; + pincl_flag: include_flag; pincl_loc: Location.t; pincl_attributes: attributes; } @@ -821,6 +837,8 @@ and structure_item_desc = (* [@@@id] *) | Pstr_extension of extension * attributes (* [%%id] *) + | Pstr_implicit of implicit_description + (* implicit Path.t *) and value_binding = { diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index 4217e79463..356ebb653b 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -90,6 +90,10 @@ let open_flag = function | Open_all x -> override x | Open_implicit -> " implicit" +let include_flag = function + | Include_all -> "" + | Include_implicit -> " implicit" + let implicit_flag = function | Nonimplicit -> "" | Implicit -> " implicit" @@ -640,7 +644,16 @@ class printer ()= object(self:'self) pp f "@[(!poly!@ %a@ : %a)@]" self#simple_expr e self#core_type ct | Pexp_open (ovf, lid, e) -> pp f "@[<2>let open%s %a in@;%a@]" (open_flag ovf) self#longident_loc lid - self#expression e + self#expression e + | Pexp_implicit(imp, e) -> + let kind = + match imp.pimp_kind with + | Pimp_implicit -> "implicit" + | Pimp_explicit -> "explicit" + in + pp f "@[<2>let %s %a in@;%a@]" + kind self#longident_loc imp.pimp_lid + self#expression e | Pexp_variant (l,Some eo) -> pp f "@[<2>`%s@;%a@]" l self#simple_expr eo | Pexp_extension e -> self#extension f e @@ -1036,7 +1049,8 @@ class printer ()= object(self:'self) self#longident_loc od.popen_lid self#item_attributes od.popen_attributes | Psig_include incl -> - pp f "@[include@ %a@]%a" + pp f "@[include%s@ %a@]%a" + (include_flag incl.pincl_flag) self#module_type incl.pincl_mod self#item_attributes incl.pincl_attributes | Psig_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> @@ -1071,6 +1085,17 @@ class printer ()= object(self:'self) | Psig_extension(e, a) -> self#item_extension f e; self#item_attributes f a + | Psig_implicit imp -> + let kind = + match imp.pimp_kind with + | Pimp_implicit -> "implicit" + | Pimp_explicit -> "explicit" + in + pp f "@[%s@ %a@]%a" + kind + self#longident_loc imp.pimp_lid + self#item_attributes imp.pimp_attributes + end method module_expr f x = if x.pmod_attributes <> [] then begin @@ -1230,7 +1255,8 @@ class printer ()= object(self:'self) self#value_description vd self#item_attributes vd.pval_attributes | Pstr_include incl -> - pp f "@[include@ %a@]%a" + pp f "@[include%s@ %a@]%a" + (include_flag incl.pincl_flag) self#module_expr incl.pincl_mod self#item_attributes incl.pincl_attributes | Pstr_recmodule decls -> (* 3.07 *) @@ -1256,6 +1282,16 @@ class printer ()= object(self:'self) | Pstr_extension(e, a) -> self#item_extension f e; self#item_attributes f a + | Pstr_implicit imp -> + let kind = + match imp.pimp_kind with + | Pimp_implicit -> "implicit" + | Pimp_explicit -> "explicit" + in + pp f "@[%s@ %a@]%a" + kind + self#longident_loc imp.pimp_lid + self#item_attributes imp.pimp_attributes end method type_param f (ct, a) = pp f "%s%a" (type_variance a) self#core_type ct diff --git a/parsing/printast.ml b/parsing/printast.ml index 98e337df24..9562f42a5f 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -88,6 +88,12 @@ let fmt_open_flag f x = | Open_implicit -> fprintf f "Open_implicit"; ;; +let fmt_include_flag f x = + match x with + | Include_all -> fprintf f "Include_all"; + | Include_implicit -> fprintf f "Include_implicit"; +;; + let fmt_closed_flag f x = match x with | Closed -> fprintf f "Closed" @@ -383,6 +389,10 @@ and expression i ppf x = line i ppf "Pexp_open %a \"%a\"\n" fmt_open_flag ovf fmt_longident_loc m; expression i ppf e + | Pexp_implicit (imp, e) -> + line i ppf "Pexp_implicit \"%a\"\n" fmt_longident_loc imp.pimp_lid; + implicit_kind i ppf imp.pimp_kind; + expression i ppf e | Pexp_extension (s, arg) -> line i ppf "Pexp_extension \"%s\"\n" s.txt; payload i ppf arg @@ -693,7 +703,8 @@ and signature_item i ppf x = fmt_longident_loc od.popen_lid; attributes i ppf od.popen_attributes | Psig_include incl -> - line i ppf "Psig_include\n"; + line i ppf "Psig_include %a\n" + fmt_include_flag incl.pincl_flag; module_type i ppf incl.pincl_mod; attributes i ppf incl.pincl_attributes | Psig_class (l) -> @@ -709,6 +720,11 @@ and signature_item i ppf x = | Psig_attribute (s, arg) -> line i ppf "Psig_attribute \"%s\"\n" s.txt; payload i ppf arg + | Psig_implicit imp -> + line i ppf "Psig_implicit %a\n" + fmt_longident_loc imp.pimp_lid; + implicit_kind i ppf imp.pimp_kind; + attributes i ppf imp.pimp_attributes and modtype_declaration i ppf = function | None -> line i ppf "#abstract" @@ -828,7 +844,8 @@ and structure_item i ppf x = line i ppf "Pstr_class_type\n"; list i class_type_declaration ppf l; | Pstr_include incl -> - line i ppf "Pstr_include"; + line i ppf "Pstr_include %a" + fmt_include_flag incl.pincl_flag; attributes i ppf incl.pincl_attributes; module_expr i ppf incl.pincl_mod | Pstr_extension ((s, arg), attrs) -> @@ -838,6 +855,11 @@ and structure_item i ppf x = | Pstr_attribute (s, arg) -> line i ppf "Pstr_attribute \"%s\"\n" s.txt; payload i ppf arg + | Pstr_implicit imp -> + line i ppf "Pstr_implicit %a\n" + fmt_longident_loc imp.pimp_lid; + implicit_kind i ppf imp.pimp_kind; + attributes i ppf imp.pimp_attributes and module_declaration i ppf pmd = string_loc i ppf pmd.pmd_name; @@ -851,6 +873,11 @@ and module_binding i ppf pmb = attributes i ppf pmb.pmb_attributes; module_expr (i+1) ppf pmb.pmb_expr +and implicit_kind i ppf kind = + match kind with + | Pimp_implicit -> line i ppf "Pimp_implicit" + | Pimp_explicit -> line i ppf "Pimp_explicit" + and core_type_x_core_type_x_location i ppf (ct1, ct2, l) = line i ppf " %a\n" fmt_location l; core_type (i+1) ppf ct1; diff --git a/tools/depend.ml b/tools/depend.ml index 1521e7574c..528858eb2b 100644 --- a/tools/depend.ml +++ b/tools/depend.ml @@ -193,6 +193,7 @@ let rec add_expr bv exp = | Pexp_newtype (_, e) -> add_expr bv e | Pexp_pack m -> add_module bv m | Pexp_open (_ovf, m, e) -> addmodule bv m; add_expr bv e + | Pexp_implicit (imp, e) -> addmodule bv imp.pimp_lid; add_expr bv e | Pexp_extension _ -> () and add_cases bv cases = @@ -267,6 +268,8 @@ and add_sig_item bv item = List.iter (add_class_description bv) cdl; bv | Psig_class_type cdtl -> List.iter (add_class_type_declaration bv) cdtl; bv + | Psig_implicit imp -> + addmodule bv imp.pimp_lid; bv | Psig_attribute _ | Psig_extension _ -> bv @@ -342,6 +345,8 @@ and add_struct_item bv item = List.iter (add_class_type_declaration bv) cdtl; bv | Pstr_include incl -> add_module bv incl.pincl_mod; bv + | Pstr_implicit od -> + addmodule bv od.pimp_lid; bv | Pstr_attribute _ | Pstr_extension _ -> bv diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml index ea44e3dbbe..6ab75f57f4 100644 --- a/tools/ocamlprof.ml +++ b/tools/ocamlprof.ml @@ -292,6 +292,7 @@ and rw_exp iflag sexp = | Pexp_newtype (_, sexp) -> rewrite_exp iflag sexp | Pexp_open (_ovf, _, e) -> rewrite_exp iflag e + | Pexp_implicit (_, e) -> rewrite_exp iflag e | Pexp_pack (smod) -> rewrite_mod iflag smod | Pexp_extension _ -> () diff --git a/tools/tast_iter.ml b/tools/tast_iter.ml index 217af6f93e..2fc09bb07a 100644 --- a/tools/tast_iter.ml +++ b/tools/tast_iter.ml @@ -29,6 +29,7 @@ let structure_item sub x = | Tstr_recmodule list -> List.iter (sub # module_binding) list | Tstr_modtype mtd -> opt (sub # module_type) mtd.mtd_type | Tstr_open _ -> () + | Tstr_implicit _ -> () | Tstr_class list -> List.iter (fun (ci, _, _) -> sub # class_expr ci.ci_expr) list | Tstr_class_type list -> @@ -97,6 +98,7 @@ let expression sub exp = | Texp_coerce (cty1, cty2) -> opt (sub # core_type) cty1; sub # core_type cty2 | Texp_open _ + | Texp_implicit _ | Texp_newtype _ -> () | Texp_poly cto -> opt (sub # core_type) cto in @@ -192,6 +194,7 @@ let signature_item sub item = | Tsig_modtype mtd -> opt (sub # module_type) mtd.mtd_type | Tsig_open _ -> () + | Tsig_implicit _ -> () | Tsig_include incl -> sub # module_type incl.incl_mod | Tsig_class list -> List.iter (sub # class_description) list diff --git a/tools/untypeast.ml b/tools/untypeast.ml index e4f0761e5d..20ba93c55b 100644 --- a/tools/untypeast.ml +++ b/tools/untypeast.ml @@ -71,6 +71,8 @@ and untype_structure_item item = popen_attributes = od.open_attributes; popen_loc = od.open_loc; } + | Tstr_implicit imp -> + Pstr_implicit (untype_implicit_description imp) | Tstr_class list -> Pstr_class (List.map @@ -83,6 +85,7 @@ and untype_structure_item item = list) | Tstr_include incl -> Pstr_include {pincl_mod = untype_module_expr incl.incl_mod; + pincl_flag = incl.incl_flag; pincl_attributes = incl.incl_attributes; pincl_loc = incl.incl_loc; } @@ -191,6 +194,18 @@ and untype_extension_constructor ext = pext_attributes = ext.ext_attributes; } +and untype_implicit_description imp = + { + pimp_lid = imp.imp_txt; + pimp_kind = untype_implicit_kind imp.imp_kind; + pimp_attributes = imp.imp_attributes; + pimp_loc = imp.imp_loc; + } + +and untype_implicit_kind = function + | Timp_implicit -> Pimp_implicit + | Timp_explicit -> Pimp_explicit + and untype_pattern pat = let desc = match pat with @@ -249,6 +264,7 @@ and untype_extra (extra, loc, attrs) sexp = | Texp_constraint cty -> Pexp_constraint (sexp, untype_core_type cty) | Texp_open (ovf, _path, lid, _) -> Pexp_open (ovf, lid, sexp) + | Texp_implicit (imp, _) -> Pexp_implicit (untype_implicit_description imp, sexp) | Texp_poly cto -> Pexp_poly (sexp, option untype_core_type cto) | Texp_newtype s -> Pexp_newtype (s, sexp) in @@ -414,8 +430,11 @@ and untype_signature_item item = popen_attributes = od.open_attributes; popen_loc = od.open_loc; } + | Tsig_implicit imp -> + Psig_implicit (untype_implicit_description imp) | Tsig_include incl -> Psig_include {pincl_mod = untype_module_type incl.incl_mod; + pincl_flag = incl.incl_flag; pincl_attributes = incl.incl_attributes; pincl_loc = incl.incl_loc; } diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml index 0ca19a814b..986deff47e 100644 --- a/toplevel/topdirs.ml +++ b/toplevel/topdirs.ml @@ -336,9 +336,9 @@ let trim_signature = function Mty_signature (List.map (function - Sig_module (id, md, rs) -> + Sig_module (id, md, is, rs) -> Sig_module (id, {md with md_type = trim_modtype md.md_type}, - rs) + is, rs) (*| Sig_modtype (id, Modtype_manifest mty) -> Sig_modtype (id, Modtype_manifest (trim_modtype mty))*) | item -> item) @@ -412,7 +412,7 @@ let () = (fun env loc id lid -> let path, md = Typetexp.find_module env loc lid in [ Sig_module (id, {md with md_type = trim_signature md.md_type}, - Trec_not) ] + Asttypes.Nonimplicit, Trec_not) ] ) let () = diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml index 62518ba073..ab74098f2b 100644 --- a/toplevel/toploop.ml +++ b/toplevel/toploop.ml @@ -197,8 +197,8 @@ let rec pr_item env items = | Sig_typext(id, ext, es) :: rem -> let tree = Printtyp.tree_of_extension_constructor id ext es in Some (tree, None, rem) - | Sig_module(id, md, rs) :: rem -> - let tree = Printtyp.tree_of_module id ~implicit_:md.md_implicit md.md_type rs in + | Sig_module(id, md, is, rs) :: rem -> + let tree = Printtyp.tree_of_module id ~implicit_:is md.md_type rs in Some (tree, None, rem) | Sig_modtype(id, decl) :: rem -> let tree = Printtyp.tree_of_modtype_declaration id decl in @@ -209,6 +209,11 @@ let rec pr_item env items = | Sig_class_type(id, decl, rs) :: tydecl1 :: tydecl2 :: rem -> let tree = Printtyp.tree_of_cltype_declaration id decl rs in Some (tree, None, rem) + | Sig_implicit(imp, Timps_standalone) :: rem -> + let tree = Printtyp.tree_of_implicit_description imp Timps_standalone in + Some (tree, None, rem) + | Sig_implicit(imp, Timps_attached) :: rem -> + pr_item env rem | _ -> None let rec item_list env = function diff --git a/typing/btype.ml b/typing/btype.ml index e8bac1e9c7..7eaa3f45cb 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -243,6 +243,7 @@ type type_iterators = it_modtype_declaration: type_iterators -> modtype_declaration -> unit; it_class_declaration: type_iterators -> class_declaration -> unit; it_class_type_declaration: type_iterators -> class_type_declaration -> unit; + it_implicit_description: type_iterators -> implicit_description -> unit; it_module_type: type_iterators -> module_type -> unit; it_module_parameter: type_iterators -> module_parameter -> unit; it_class_type: type_iterators -> class_type -> unit; @@ -258,10 +259,11 @@ let type_iterators = Sig_value (_, vd) -> it.it_value_description it vd | Sig_type (_, td, _) -> it.it_type_declaration it td | Sig_typext (_, td, _) -> it.it_extension_constructor it td - | Sig_module (_, md, _) -> it.it_module_declaration it md + | Sig_module (_, md, _, _) -> it.it_module_declaration it md | Sig_modtype (_, mtd) -> it.it_modtype_declaration it mtd | Sig_class (_, cd, _) -> it.it_class_declaration it cd | Sig_class_type (_, ctd, _) -> it.it_class_type_declaration it ctd + | Sig_implicit _ -> (*FIXME: do something?*) () and it_value_description it vd = it.it_type_expr it vd.val_type and it_type_declaration it td = @@ -286,6 +288,8 @@ let type_iterators = List.iter (it.it_type_expr it) ctd.clty_params; it.it_class_type it ctd.clty_type; it.it_path ctd.clty_path + and it_implicit_description it imp = + it.it_path imp.imp_path and it_module_type it = function Mty_ident p | Mty_alias p -> it.it_path p @@ -336,8 +340,9 @@ let type_iterators = { it_path; it_type_expr = it_do_type_expr; it_do_type_expr; it_type_kind; it_class_type; it_module_type; it_module_parameter; it_signature; it_class_type_declaration; it_class_declaration; - it_modtype_declaration; it_module_declaration; it_extension_constructor; - it_type_declaration; it_value_description; it_signature_item; } + it_implicit_description; it_modtype_declaration; it_module_declaration; + it_extension_constructor; it_type_declaration; it_value_description; + it_signature_item; } let copy_row f fixed row keep more = let fields = List.map diff --git a/typing/btype.mli b/typing/btype.mli index fc4a37b619..3581ea0e62 100644 --- a/typing/btype.mli +++ b/typing/btype.mli @@ -99,6 +99,7 @@ type type_iterators = it_modtype_declaration: type_iterators -> modtype_declaration -> unit; it_class_declaration: type_iterators -> class_declaration -> unit; it_class_type_declaration: type_iterators -> class_type_declaration -> unit; + it_implicit_description: type_iterators -> implicit_description -> unit; it_module_type: type_iterators -> module_type -> unit; it_module_parameter : type_iterators -> Types.module_parameter -> unit; it_class_type: type_iterators -> class_type -> unit; diff --git a/typing/cmt_format.ml b/typing/cmt_format.ml index 6cecb1b691..1f945a9018 100644 --- a/typing/cmt_format.ml +++ b/typing/cmt_format.ml @@ -77,6 +77,8 @@ module ClearEnv = TypedtreeMap.MakeMap (struct let exp_extra = List.map (function (Texp_open (ovf, path, lloc, env), loc, attrs) -> (Texp_open (ovf, path, lloc, keep_only_summary env), loc, attrs) + | (Texp_implicit (imp, env), loc, attrs) -> + (Texp_implicit (imp, keep_only_summary env), loc, attrs) | exp_extra -> exp_extra) e.exp_extra in { e with exp_env = keep_only_summary e.exp_env; diff --git a/typing/env.ml b/typing/env.ml index c317e503f8..0ca8598f58 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -53,6 +53,8 @@ let used_constructors : let prefixed_sg = Hashtbl.create 113 +let prefixed_imps = Hashtbl.create 113 + type error = | Illegal_renaming of string * string * string | Inconsistent_import of string * string * string @@ -112,6 +114,8 @@ type summary = | Env_class of summary * Ident.t * class_declaration | Env_cltype of summary * Ident.t * class_type_declaration | Env_open of summary * Path.t + | Env_open_implicit of summary * Path.t + | Env_implicit of summary * implicit_description | Env_functor_arg of summary * Ident.t module EnvTbl = @@ -291,8 +295,8 @@ let strengthen = ref ((fun env mty path -> assert false) : t -> module_type -> Path.t -> module_type) -let md ?(implicit_ = Asttypes.Nonimplicit) md_type = - {md_type; md_attributes=[]; md_loc=Location.none; md_implicit = implicit_} +let md md_type = + {md_type; md_attributes=[]; md_loc=Location.none;} (* The name of the compilation unit currently compiled. "" if outside a compilation unit. *) @@ -393,7 +397,8 @@ let reset_cache () = Hashtbl.clear value_declarations; Hashtbl.clear type_declarations; Hashtbl.clear used_constructors; - Hashtbl.clear prefixed_sg + Hashtbl.clear prefixed_sg; + Hashtbl.clear prefixed_imps let reset_cache_toplevel () = (* Delete 'missing cmi' entries from the cache. *) @@ -406,7 +411,8 @@ let reset_cache_toplevel () = Hashtbl.clear value_declarations; Hashtbl.clear type_declarations; Hashtbl.clear used_constructors; - Hashtbl.clear prefixed_sg + Hashtbl.clear prefixed_sg; + Hashtbl.clear prefixed_imps let set_unit_name name = @@ -1109,6 +1115,37 @@ let rec scrape_alias env ?path mty = let scrape_alias env mty = scrape_alias env mty +(* Follow all aliases in a path *) + +(* CR-someday lwhite: why is this different from normalize path? + In fact why are they even necessery? Really aliases in the path + should be reflected (by strengthening) as aliases on the item + pointed to by the path. + *) +let rec canonical_path env path = + try + let md = find_module path env in + match md.Types.md_type with + | Mty_alias path -> canonical_path env path + | _ -> match path with + | Path.Pident _ -> path + | Path.Pdot (p1,s,pos) -> + let p1' = canonical_path env p1 in + if p1 == p1' then + path + else + Path.Pdot (p1', s, pos) + | Path.Papply (p1, p2, i) -> + let p1' = canonical_path env p1 + and p2' = canonical_path env p2 in + if p1' == p1 && p2 == p2' then + path + else + Path.Papply (p1', p2', i) + with Not_found -> + (*?!*) + path + (* Compute constructor descriptions *) let constructors_of_type ty_path decl = @@ -1143,24 +1180,30 @@ let signature_item_size = function | Sig_type _ -> 0 | Sig_modtype _ -> 0 | Sig_class_type _ -> 0 + | Sig_implicit _ -> 0 let signature_item_subst item p sub = match item with | Sig_type (id, _, _) -> Subst.add_type id p sub - | Sig_module (id, _, _) -> Subst.add_module id p sub + | Sig_module (id, _, _, _) -> Subst.add_module id p sub | Sig_modtype (id, _) -> Subst.add_modtype id (Mty_ident p) sub - | Sig_value _ | Sig_typext _ | Sig_class _ | Sig_class_type _ -> sub + | Sig_value _ | Sig_typext _ | Sig_implicit _ + | Sig_class _ | Sig_class_type _ -> sub let signature_item_ident = function | Sig_value (id, _) | Sig_typext (id, _, _) | Sig_type (id, _, _) - | Sig_module (id, _, _) | Sig_modtype (id, _) + | Sig_module (id, _, _, _) | Sig_modtype (id, _) | Sig_class (id, _, _) | Sig_class_type (id, _, _) -> id + | Sig_implicit _ -> assert false (* Given a signature and a root path, prefix all idents in the signature by the root path and build the corresponding substitution. *) let rec prefix_idents root pos sub = function - [] -> ([], sub) + | [] -> ([], sub) + | Sig_implicit _ :: rem -> + let (pl, final_sub) = prefix_idents root pos sub rem in + (Path.dummy :: pl, final_sub) | item :: rem -> let id = signature_item_ident item in let size = signature_item_size item in @@ -1181,14 +1224,16 @@ let subst_signature sub sg = Sig_type(id, Subst.type_declaration sub decl, x) | Sig_typext(id, ext, es) -> Sig_typext (id, Subst.extension_constructor sub ext, es) - | Sig_module(id, mty, x) -> - Sig_module(id, Subst.module_declaration sub mty,x) + | Sig_module(id, mty, x, y) -> + Sig_module(id, Subst.module_declaration sub mty, x, y) | Sig_modtype(id, decl) -> Sig_modtype(id, Subst.modtype_declaration sub decl) | Sig_class(id, decl, x) -> Sig_class(id, Subst.class_declaration sub decl, x) | Sig_class_type(id, decl, x) -> Sig_class_type(id, Subst.cltype_declaration sub decl, x) + | Sig_implicit(imp, x) -> + Sig_implicit (Subst.implicit_description sub imp, x) ) sg @@ -1216,10 +1261,41 @@ let prefix_idents_and_subst root sub sg = else prefix_idents_and_subst root sub sg -let register_if_implicit path md env = - match md.md_implicit with - | Asttypes.Nonimplicit -> env - | Asttypes.Implicit -> +let prefixed_implicits root sg = + let (_, sub) = prefix_idents root 0 Subst.identity sg in + let rev_imps = + List.fold_left + (fun acc item -> + match item with + | Sig_implicit(imp, _) -> + let imp = Subst.implicit_description sub imp in + imp :: acc + | _ -> acc) + [] sg + in + let imps = List.rev rev_imps in + imps + +let prefixed_implicits root sg = + let sgs = + try + Hashtbl.find prefixed_imps root + with Not_found -> + let sgs = ref [] in + Hashtbl.add prefixed_imps root sgs; + sgs + in + try + List.assq sg !sgs + with Not_found -> + let r = prefixed_implicits root sg in + sgs := (sg, r) :: !sgs; + r + +let register_as_implicit path env = + let path = canonical_path env path in + try + let md = find_module path env in let mty = !strengthen env md.md_type path in let rec add acc params mty = let acc = ((path, List.rev params, mty) :: acc) in @@ -1231,6 +1307,28 @@ let register_if_implicit path md env = in let implicit_instances = add env.implicit_instances [] mty in {env with implicit_instances} + with Not_found -> + (* Can happen if the environment is ill-formed (e.g. whilst printing types). + In these cases we do not care about the implicit scope anyway. *) + env + + +let unregister_as_implicit path env = + let path = canonical_path env path in + let implicit_instances = + List.filter + (fun (p, _, _) -> not (Path.same path p)) + env.implicit_instances + in + {env with implicit_instances} + +let add_implicit imp env = + let env = + match imp.imp_kind with + | Imp_implicit -> register_as_implicit imp.imp_path env + | Imp_explicit -> unregister_as_implicit imp.imp_path env + in + { env with summary = Env_implicit(env.summary, imp) } (* Compute structure descriptions *) @@ -1289,7 +1387,7 @@ and components_of_module_maker (env, sub, path, mty) = c.comp_constrs <- add_to_tbl (Ident.name id) (descr, !pos) c.comp_constrs; incr pos - | Sig_module(id, md, _) -> + | Sig_module(id, md, _, _) -> let mty = md.md_type in let mty' = EnvLazy.create (sub, mty) in c.comp_modules <- @@ -1312,7 +1410,8 @@ and components_of_module_maker (env, sub, path, mty) = | Sig_class_type(id, decl, _) -> let decl' = Subst.cltype_declaration sub decl in c.comp_cltypes <- - Tbl.add (Ident.name id) (decl', !pos) c.comp_cltypes) + Tbl.add (Ident.name id) (decl', !pos) c.comp_cltypes + | Sig_implicit _ -> ()) sg pl; Structure_comps c | Mty_functor(param, ty_res) -> @@ -1451,17 +1550,14 @@ and store_extension ~check slot id path ext env renv = summary = Env_extension(env.summary, id, ext) } and store_module slot id path md env renv = - let env = - { env with - modules = EnvTbl.add "module" slot id (path, md) env.modules renv.modules; - components = - EnvTbl.add "module" slot id - (path, components_of_module env Subst.identity path md.md_type) - env.components renv.components; - summary = Env_module(env.summary, id, md); - } - in - register_if_implicit path md env + { env with + modules = EnvTbl.add "module" slot id (path, md) env.modules renv.modules; + components = + EnvTbl.add "module" slot id + (path, components_of_module env Subst.identity path md.md_type) + env.components renv.components; + summary = Env_module(env.summary, id, md); + } and store_modtype slot id path info env renv = { env with @@ -1560,8 +1656,8 @@ and add_class id ty env = and add_cltype id ty env = store_cltype None id (Pident id) ty env env -let add_module ?arg ?implicit_ id mty env = - add_module_declaration ?arg id (md ?implicit_ mty) env +let add_module ?arg id mty env = + add_module_declaration ?arg id (md mty) env let add_local_constraint id info elv env = match info with @@ -1591,7 +1687,17 @@ and enter_class = enter store_class and enter_cltype = enter store_cltype let enter_module ?arg ~implicit_ s mty env = - enter_module_declaration ?arg s (md ~implicit_ mty) env + let id, env = enter_module_declaration ?arg s (md mty) env in + match implicit_ with + | Nonimplicit -> id, env + | Implicit -> + let path = Pident id in + let imp = + {imp_path = path; imp_kind = Imp_implicit; + imp_attributes=[]; imp_loc=Location.none;} + in + let env = add_implicit imp env in + id, env (* Insertion of all components of a signature *) @@ -1600,10 +1706,11 @@ let add_item comp env = Sig_value(id, decl) -> add_value id decl env | Sig_type(id, decl, _) -> add_type ~check:false id decl env | Sig_typext(id, ext, _) -> add_extension ~check:false id ext env - | Sig_module(id, md, _) -> add_module_declaration id md env + | Sig_module(id, md, _, _) -> add_module_declaration id md env | Sig_modtype(id, decl) -> add_modtype id decl env | Sig_class(id, decl, _) -> add_class id decl env | Sig_class_type(id, decl, _) -> add_cltype id decl env + | Sig_implicit(imp, _) -> add_implicit imp env let rec add_signature sg env = match sg with @@ -1629,7 +1736,7 @@ let open_signature slot root sg env0 = store_type ~check:false slot (Ident.hide id) p decl env env0 | Sig_typext(id, ext, _) -> store_extension ~check:false slot (Ident.hide id) p ext env env0 - | Sig_module(id, mty, _) -> + | Sig_module(id, mty, _, _) -> store_module slot (Ident.hide id) p mty env env0 | Sig_modtype(id, decl) -> store_modtype slot (Ident.hide id) p decl env env0 @@ -1637,6 +1744,8 @@ let open_signature slot root sg env0 = store_class slot (Ident.hide id) p decl env env0 | Sig_class_type(id, decl, _) -> store_cltype slot (Ident.hide id) p decl env env0 + | Sig_implicit(imp, _) -> + add_implicit imp env ) env0 sg pl in { newenv with summary = Env_open(env0.summary, root) } @@ -1678,18 +1787,13 @@ let open_signature ?(loc = Location.none) ?(toplevel = false) ovf root sg env = else open_signature None root sg env let open_implicit root sg env = - let env, _pos = List.fold_left - (fun (env,pos) item -> - let env = match item with - | Sig_module(id, md, _) -> - register_if_implicit (Pdot (root, Ident.name id, pos)) md env - | _ -> env - in - let next = pos + signature_item_size item in - env, next) - (env,0) sg + let imps = prefixed_implicits root sg in + let newenv = + List.fold_left + (fun env imp -> add_implicit imp env) + env imps in - env + { newenv with summary = Env_open_implicit(env.summary, root) } (* Read a signature from a file *) diff --git a/typing/env.mli b/typing/env.mli index 329f8be7e4..f819f814bc 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -24,6 +24,8 @@ type summary = | Env_class of summary * Ident.t * class_declaration | Env_cltype of summary * Ident.t * class_type_declaration | Env_open of summary * Path.t + | Env_open_implicit of summary * Path.t + | Env_implicit of summary * Types.implicit_description | Env_functor_arg of summary * Ident.t type t @@ -112,12 +114,13 @@ val add_value: ?check:(string -> Warnings.t) -> Ident.t -> value_description -> t -> t val add_type: check:bool -> Ident.t -> type_declaration -> t -> t val add_extension: check:bool -> Ident.t -> extension_constructor -> t -> t -val add_module: ?arg:bool -> ?implicit_:Asttypes.implicit_flag -> Ident.t -> module_type -> t -> t +val add_module: ?arg:bool -> Ident.t -> module_type -> t -> t val add_module_declaration: ?arg:bool -> Ident.t -> module_declaration -> t -> t val add_modtype: Ident.t -> modtype_declaration -> t -> t val add_class: Ident.t -> class_declaration -> t -> t val add_cltype: Ident.t -> class_type_declaration -> t -> t val add_local_constraint: Ident.t -> type_declaration -> int -> t -> t +val add_implicit: implicit_description -> t -> t (* Insertion of all fields of a signature. *) @@ -267,3 +270,4 @@ val fold_cltypes: (** Utilities *) val scrape_alias: t -> module_type -> module_type +val canonical_path: t -> Path.t -> Path.t diff --git a/typing/envaux.ml b/typing/envaux.ml index 708da443d2..d7ccdd6f4f 100644 --- a/typing/envaux.ml +++ b/typing/envaux.ml @@ -75,6 +75,20 @@ let rec env_from_summary sum subst = in Env.open_signature Asttypes.Override path' (extract_sig env md.md_type) env + | Env_open_implicit(s, path) -> + let env = env_from_summary s subst in + let path' = Subst.module_path subst path in + let md = + try + Env.find_module path' env + with Not_found -> + raise (Error (Module_not_found path')) + in + Env.open_implicit path' (extract_sig env md.md_type) env + | Env_implicit(s, imp) -> + let env = env_from_summary s subst in + let imp' = Subst.implicit_description subst imp in + Env.add_implicit imp' env | Env_functor_arg(Env_module(s, id, desc), id') when Ident.same id id' -> Env.add_module_declaration id (Subst.module_declaration subst desc) ~arg:true (env_from_summary s subst) diff --git a/typing/ident.ml b/typing/ident.ml index 5302a61284..b2fc903439 100644 --- a/typing/ident.ml +++ b/typing/ident.ml @@ -25,6 +25,8 @@ let create s = incr currentstamp; { name = s; stamp = !currentstamp; flags = 0 } +let dummy = create "*dummy*" + let create_predef_exn s = incr currentstamp; { name = s; stamp = !currentstamp; flags = predef_exn_flag } diff --git a/typing/ident.mli b/typing/ident.mli index 601898b47b..c8a48a8c4d 100644 --- a/typing/ident.mli +++ b/typing/ident.mli @@ -15,6 +15,7 @@ type t = { stamp: int; name: string; mutable flags: int } val create: string -> t +val dummy: t val create_persistent: string -> t val create_predef_exn: string -> t val rename: t -> t diff --git a/typing/implicitsearch.ml b/typing/implicitsearch.ml index f794afc33c..4d832ea104 100644 --- a/typing/implicitsearch.ml +++ b/typing/implicitsearch.ml @@ -142,11 +142,11 @@ module Constraints = struct | _ -> env in aux env id ty items - | Sig_module (id, decl, (Trec_not | Trec_first)) :: items -> + | Sig_module (id, decl, _, (Trec_not | Trec_first)) :: items -> let rec aux env id decl items = let env = Env.add_module_declaration id decl env in match items with - | Sig_module (id, decl, Trec_next) :: items -> + | Sig_module (id, decl, _, Trec_next) :: items -> aux env id decl items | _ -> env in @@ -175,7 +175,7 @@ module Constraints = struct and prepare_sig_item env cstrs field = match field with - | Sig_value _ | Sig_class _ | Sig_modtype _ + | Sig_value _ | Sig_class _ | Sig_modtype _ | Sig_implicit _ | Sig_class_type _ | Sig_typext _ -> [], cstrs, field | Sig_type (id,decl,recst) -> @@ -193,7 +193,7 @@ module Constraints = struct with Not_found -> [], cstrs, field end - | Sig_module (id,decl,recst) -> + | Sig_module (id,decl,impf,recst) -> let name = Ident.name id in begin try let (_, subs), cstrs = list_extract (name_match name) cstrs in @@ -204,7 +204,7 @@ module Constraints = struct | subs -> [(id, Sub subs)] in to_unify, cstrs, - Sig_module (id,{decl with md_type = mty}, recst) + Sig_module (id, {decl with md_type = mty}, impf, recst) with Not_found -> [], cstrs, field end @@ -250,12 +250,12 @@ module Constraints = struct unify env ty ty'; cstrs - | Sig_module (id,decl,recst), + | Sig_module (id,decl,_,_), ((id', Sub subs) :: cstrs) when Ident.same id id' -> constraint_mty env subs decl.md_type; cstrs - | _ -> cstrs + | _ -> cstrs and constraint_sig env cstrs items = let env = register_items env items in @@ -968,9 +968,6 @@ end = struct | target :: sub_targets -> let partial = {partial with payload = (path, sub_targets) } in let md = Env.find_module path arg.env in - (* The original module declaration might be implicit, we want to avoid - rebinding implicit *) - let md = {md with md_implicit = Asttypes.Nonimplicit} in let target = Constraints.target arg.env target eq_initial in let termination = Termination.check_target arg.env target eq_initial partial.termination in let env = Env.add_module_declaration target.target_id md arg.env in @@ -1030,30 +1027,6 @@ module Solution = struct let get {result} = Search.get result end -let rec canonical_path env path = - try - let md = Env.find_module path env in - match md.Types.md_type with - | Mty_alias path -> canonical_path env path - | _ -> match path with - | Path.Pident _ -> path - | Path.Pdot (p1,s,pos) -> - let p1' = canonical_path env p1 in - if p1 == p1' then - path - else - Path.Pdot (p1', s, pos) - | Path.Papply (p1, p2, i) -> - let p1' = canonical_path env p1 - and p2' = canonical_path env p2 in - if p1' == p1 && p2 == p2' then - path - else - Path.Papply (p1', p2', i) - with Not_found -> - (*?!*) - path - let find_pending_instance inst = let snapshot = Btype.snapshot () in let vars, target = target_of_pending inst in @@ -1081,14 +1054,14 @@ let find_pending_instance inst = try let solution = Solution.search query in let path = Solution.get solution in - let reference = canonical_path env path in + let reference = Env.canonical_path env path in let rec check_alternatives solution = match (try Some (Solution.search_next solution) with _ -> None) with | Some alternative -> let path' = Solution.get alternative in - let reference' = canonical_path env (Solution.get alternative) in + let reference' = Env.canonical_path env (Solution.get alternative) in if reference = reference' then check_alternatives alternative else diff --git a/typing/includemod.ml b/typing/includemod.ml index 1acafd96f0..c60feba7aa 100644 --- a/typing/includemod.ml +++ b/typing/includemod.ml @@ -19,7 +19,6 @@ open Types type symptom = Missing_field of Ident.t * Location.t * string (* kind *) - | Implicit_flags of Ident.t * Location.t * Location.t | Value_descriptions of Ident.t * value_description * value_description | Type_declarations of Ident.t * type_declaration * type_declaration * Includecore.type_mismatch list @@ -38,6 +37,8 @@ type symptom = | Unbound_modtype_path of Path.t | Unbound_module_path of Path.t | Invalid_module_alias of Path.t + | Missing_implicit of implicit_description + | Reordered_implicits of implicit_description * implicit_description type pos = | Module of Ident.t @@ -58,15 +59,6 @@ exception Error of error list 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 implicit flags *) - -let implicit_flags env cxt id f1 l1 f2 l2 = - match f1, f2 with - | Asttypes.Implicit, Asttypes.Implicit -> () - | Asttypes.Implicit, Asttypes.Nonimplicit -> () - | Asttypes.Nonimplicit, Asttypes.Nonimplicit -> () - | _ -> raise(Error[cxt, env, Implicit_flags(id, l1, l2)]) - (* Inclusion between value descriptions *) let value_descriptions env cxt subst id vd1 vd2 = @@ -161,19 +153,21 @@ 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, _) -> (id, d.ext_loc, Field_typext(Ident.name id)) - | Sig_module(id, d, _) -> (id, d.md_loc, Field_module(Ident.name id)) + | 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)) + | Sig_implicit _ -> assert false let is_runtime_component = function | Sig_value(_,{val_kind = Val_prim _}) | Sig_type(_,_,_) | Sig_modtype(_,_) + | Sig_implicit _ | Sig_class_type(_,_,_) -> false | Sig_value(_,_) | Sig_typext(_,_,_) - | Sig_module(_,_,_) + | Sig_module(_,_,_,_) | Sig_class(_, _,_) -> true (* Print a coercion *) @@ -221,6 +215,63 @@ let simplify_structure_coercion cc id_pos_list = then Tcoerce_none else Tcoerce_structure (cc, id_pos_list) +(* Check inclusion between a signature's implicits *) + +let check_implicits env cxt subst imps1 imps2 = + let mem_implicit imps imp = + let kind = imp.imp_kind in + let path = Env.canonical_path env imp.imp_path in + List.exists + (fun imp' -> + if imp'.imp_kind = kind then begin + let path' = Env.canonical_path env imp'.imp_path in + Path.same path path' + end else false) + imps + in + let find_implicit imps imp = + let kind = imp.imp_kind in + let path = Env.canonical_path env imp.imp_path in + let rec loop acc = function + | [] -> raise Not_found + | imp' :: rem -> + if imp'.imp_kind = kind then begin + let path' = Env.canonical_path env imp'.imp_path in + if Path.same path path' then List.rev acc, rem + else loop (imp' :: acc) rem + end else loop (imp' :: acc) rem + in + loop [] imps + in + let rec loop passed prev imps exps rem = function + | [] -> () + | next :: rest -> + let next = Subst.implicit_description subst next in + try + match next.imp_kind with + | Imp_implicit -> + if mem_implicit imps next then + loop passed prev imps exps rem rest + else + let before, after = find_implicit rem next in + loop (passed @ exps) (Some next) (imps @ before) [] after rest + | Imp_explicit -> + if mem_implicit exps next then + loop passed prev imps exps rem rest + else + let before, after = find_implicit rem next in + loop (passed @ imps) (Some next) [] (exps @ before) after rest + with Not_found -> + if mem_implicit passed next + || mem_implicit imps next + || mem_implicit exps next then + let prev = Misc.opt_value prev in + raise(Error[cxt, env, Reordered_implicits(prev, next)]) + else + raise(Error[cxt, env, Missing_implicit next]) + in + loop [] None [] [] imps1 imps2 + (* Inclusion between module types. Return the restriction that transforms a value of the smaller type into a value of the bigger type. *) @@ -321,45 +372,50 @@ and signatures env cxt subst sig1 sig2 = let (id_pos_list,_) = List.fold_left (fun (l,pos) -> function - Sig_module (id, _, _) -> + Sig_module (id, _, _, _) -> ((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. + (* Build a table of the named 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 + let rec build_component_table pos tbl imps = function + [] -> pos, tbl, List.rev imps + | Sig_implicit(imp, _) :: rem -> + build_component_table pos tbl (imp :: imps) rem | item :: rem -> let (id, _loc, name) = item_ident_name item in let nextpos = if is_runtime_component item then pos + 1 else pos in build_component_table nextpos - (Tbl.add name (id, item, pos) tbl) rem in - let len1, comps1 = - build_component_table 0 Tbl.empty sig1 in + (Tbl.add name (id, item, pos) tbl) imps rem in + let len1, comps1, imps1 = + build_component_table 0 Tbl.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, + (* Pair each named 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 + let rec pair_components subst paired unpaired imps = function [] -> begin match unpaired with [] -> let cc = signature_components new_env cxt subst (List.rev paired) in + check_implicits new_env cxt subst imps1 (List.rev imps); 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 + | Sig_implicit(imp, _) :: rem -> + pair_components subst paired unpaired (imp :: imps) rem | item2 :: rem -> let (id2, loc, name2) = item_ident_name item2 in let name2, report = @@ -382,22 +438,22 @@ and signatures env cxt subst sig1 sig2 = Subst.add_module id2 (Pident id1) subst | Sig_modtype _ -> Subst.add_modtype id2 (Mty_ident (Pident id1)) subst - | Sig_value _ | Sig_typext _ + | Sig_value _ | Sig_typext _ | Sig_implicit _ | Sig_class _ | Sig_class_type _ -> subst in pair_components new_subst - ((item1, item2, pos1) :: paired) unpaired rem + ((item1, item2, pos1) :: paired) unpaired imps 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 + pair_components subst paired unpaired imps rem end in (* Do the pairing and checking, and return the final coercion *) - pair_components subst [] [] sig2 + pair_components subst [] [] [] sig2 (* Inclusion between signature components *) @@ -416,13 +472,10 @@ and signature_components env cxt subst = function :: rem -> extension_constructors env cxt subst id1 ext1 ext2; (pos, Tcoerce_none) :: signature_components env cxt subst rem - | (Sig_module(id1, mty1, _), Sig_module(id2, mty2, _), pos) :: rem -> + | (Sig_module(id1, mty1, _, _), Sig_module(id2, mty2, _, _), pos) :: rem -> let cc = modtypes env (Module id1::cxt) subst (Mtype.strengthen env mty1.md_type (Pident id1)) mty2.md_type in - implicit_flags env cxt id1 - mty1.md_implicit mty1.md_loc - mty2.md_implicit mty2.md_loc; (pos, cc) :: signature_components env cxt subst rem | (Sig_modtype(id1, info1), Sig_modtype(id2, info2), pos) :: rem -> modtype_infos env cxt subst id1 info1 info2; @@ -515,9 +568,6 @@ let include_err ppf = function | Missing_field (id, loc, kind) -> fprintf ppf "The %s `%a' is required but not provided" kind ident id; show_loc "Expected declaration" ppf loc - | Implicit_flags (id, l1, l2) -> - fprintf ppf "Implicit annotations of %a do not match" ident id; - show_locs ppf (l1, l2) | Value_descriptions(id, d1, d2) -> fprintf ppf "@[Values do not match:@ %a@;<1 -2>is not included in@ %a@]" @@ -576,6 +626,17 @@ let include_err ppf = function fprintf ppf "Unbound module %a" Printtyp.path path | Invalid_module_alias path -> fprintf ppf "Module %a cannot be aliased" Printtyp.path path + | Missing_implicit imp -> + fprintf ppf "`%a %a' is required but not provided" + Printtyp.implicit_kind imp.imp_kind + Printtyp.path imp.imp_path; + show_loc "Expected declaration" ppf imp.imp_loc + | Reordered_implicits(imp1, imp2) -> + fprintf ppf "`%a %a' and `%a %a' have been reordered" + Printtyp.implicit_kind imp1.imp_kind + Printtyp.path imp1.imp_path + Printtyp.implicit_kind imp2.imp_kind + Printtyp.path imp2.imp_path let rec context ppf = function Module id :: rem -> diff --git a/typing/includemod.mli b/typing/includemod.mli index 61e599b1d5..370e31379b 100644 --- a/typing/includemod.mli +++ b/typing/includemod.mli @@ -26,7 +26,6 @@ val print_coercion: formatter -> module_coercion -> unit type symptom = Missing_field of Ident.t * Location.t * string (* kind *) - | Implicit_flags of Ident.t * Location.t * Location.t | Value_descriptions of Ident.t * value_description * value_description | Type_declarations of Ident.t * type_declaration * type_declaration * Includecore.type_mismatch list @@ -45,6 +44,8 @@ type symptom = | Unbound_modtype_path of Path.t | Unbound_module_path of Path.t | Invalid_module_alias of Path.t + | Missing_implicit of implicit_description + | Reordered_implicits of implicit_description * implicit_description type pos = | Module of Ident.t diff --git a/typing/mtype.ml b/typing/mtype.ml index ee9bef23c6..56acbb0399 100644 --- a/typing/mtype.ml +++ b/typing/mtype.ml @@ -67,9 +67,9 @@ and strengthen_sig env sg p = Sig_type(id, newdecl, rs) :: strengthen_sig env rem p | (Sig_typext(id, ext, es) as sigelt) :: rem -> sigelt :: strengthen_sig env rem p - | Sig_module(id, md, rs) :: rem -> + | Sig_module(id, md, is, rs) :: rem -> let str = strengthen_decl env md (Pdot(p, Ident.name id, nopos)) in - Sig_module(id, str, rs) + Sig_module(id, str, is, rs) :: strengthen_sig (Env.add_module_declaration id md env) rem p (* Need to add the module in case it defines manifest module types *) | Sig_modtype(id, decl) :: rem -> @@ -87,6 +87,8 @@ and strengthen_sig env sg p = sigelt :: strengthen_sig env rem p | (Sig_class_type(id, decl, rs) as sigelt) :: rem -> sigelt :: strengthen_sig env rem p + | (Sig_implicit _ as sigelt) :: rem -> + sigelt :: strengthen_sig env rem p and strengthen_decl env md p = {md with md_type = strengthen env md.md_type p} @@ -150,8 +152,8 @@ let nondep_supertype env mid mty = | Sig_typext(id, ext, es) -> Sig_typext(id, Ctype.nondep_extension_constructor env mid ext, es) :: rem' - | Sig_module(id, md, rs) -> - Sig_module(id, {md with md_type=nondep_mty env va md.md_type}, rs) + | Sig_module(id, md, is, rs) -> + Sig_module(id, {md with md_type=nondep_mty env va md.md_type}, is, rs) :: rem' | Sig_modtype(id, d) -> begin try @@ -168,13 +170,25 @@ let nondep_supertype env mid mty = | Sig_class_type(id, d, rs) -> Sig_class_type(id, Ctype.nondep_cltype_declaration env mid d, rs) :: rem' + | Sig_implicit(imp, is) -> + Sig_implicit(nondep_implicit env imp, is) + :: rem' and nondep_modtype_decl env mtd = {mtd with mtd_type = Misc.may_map (nondep_mty env Strict) mtd.mtd_type} + and nondep_implicit env imp = + let path = imp.imp_path in + if Path.isfree mid path then + let path = Env.normalize_path None env path in + if Path.isfree mid path then raise Not_found + else { imp with imp_path = path } + else imp + in nondep_mty env Co mty + let enrich_typedecl env p decl = match decl.type_manifest with Some ty -> decl @@ -199,12 +213,12 @@ and enrich_item env p = function Sig_type(id, decl, rs) -> Sig_type(id, enrich_typedecl env (Pdot(p, Ident.name id, nopos)) decl, rs) - | Sig_module(id, md, rs) -> + | Sig_module(id, md, is, rs) -> Sig_module(id, {md with md_type = enrich_modtype env (Pdot(p, Ident.name id, nopos)) md.md_type}, - rs) + is, rs) | item -> item let rec type_paths env p mty = @@ -222,14 +236,14 @@ and type_paths_sig env p pos sg = type_paths_sig env p pos' rem | Sig_type(id, decl, _) :: rem -> Pdot(p, Ident.name id, nopos) :: type_paths_sig env p pos rem - | Sig_module(id, md, _) :: rem -> + | Sig_module(id, md, _, _) :: rem -> type_paths env (Pdot(p, Ident.name id, pos)) md.md_type @ type_paths_sig (Env.add_module_declaration id md env) p (pos+1) rem | Sig_modtype(id, decl) :: rem -> type_paths_sig (Env.add_modtype id decl env) p pos rem | (Sig_typext _ | Sig_class _) :: rem -> type_paths_sig env p (pos+1) rem - | (Sig_class_type _) :: rem -> + | (Sig_class_type _ | Sig_implicit _) :: rem -> type_paths_sig env p pos rem let rec no_code_needed env mty = @@ -247,10 +261,10 @@ and no_code_needed_sig env sg = | Val_prim _ -> no_code_needed_sig env rem | _ -> false end - | Sig_module(id, md, _) :: rem -> + | Sig_module(id, md, _, _) :: rem -> no_code_needed env md.md_type && no_code_needed_sig (Env.add_module_declaration id md env) rem - | (Sig_type _ | Sig_modtype _ | Sig_class_type _) :: rem -> + | (Sig_type _ | Sig_modtype _ | Sig_class_type _ | Sig_implicit _) :: rem -> no_code_needed_sig env rem | (Sig_typext _ | Sig_class _) :: rem -> false @@ -279,13 +293,14 @@ and contains_type_item env = function {type_kind = Type_abstract; type_private = Private}),_) | Sig_modtype _ -> raise Exit - | Sig_module (_, {md_type = mty}, _) -> + | Sig_module (_, {md_type = mty}, _, _) -> contains_type env mty | Sig_value _ | Sig_type _ | Sig_typext _ | Sig_class _ - | Sig_class_type _ -> + | Sig_class_type _ + | Sig_implicit _-> () let contains_type env mty = @@ -347,12 +362,12 @@ let collect_arg_paths mty = and it_signature_item it si = type_iterators.it_signature_item it si; match si with - Sig_module (id, {md_type=Mty_alias p}, _) -> + Sig_module (id, {md_type=Mty_alias p}, _, _) -> bindings := Ident.add id p !bindings - | Sig_module (id, {md_type=Mty_signature sg}, _) -> + | Sig_module (id, {md_type=Mty_signature sg}, _, _) -> List.iter (function - | Sig_module (id', _, _) -> + | Sig_module (id', _, _, _) -> subst := PathMap.add (Pdot (Pident id, Ident.name id', -1)) id' !subst | _ -> ()) @@ -377,7 +392,7 @@ let rec remove_aliases env excl mty = and remove_aliases_sig env excl sg = match sg with [] -> [] - | Sig_module(id, md, rs) :: rem -> + | Sig_module(id, md, is, rs) :: rem -> let mty = match md.md_type with Mty_alias _ when IdentSet.mem id excl -> @@ -385,9 +400,8 @@ and remove_aliases_sig env excl sg = | mty -> remove_aliases env excl mty in - let implicit_ = md.md_implicit in - Sig_module(id, {md with md_type = mty} , rs) :: - remove_aliases_sig (Env.add_module ~implicit_ id mty env) excl rem + Sig_module(id, {md with md_type = mty} , is, rs) :: + remove_aliases_sig (Env.add_module id mty env) excl rem | Sig_modtype(id, mtd) :: rem -> Sig_modtype(id, mtd) :: remove_aliases_sig (Env.add_modtype id mtd env) excl rem @@ -399,3 +413,31 @@ let remove_aliases env sg = (* PathSet.iter (fun p -> Format.eprintf "%a@ " Printtyp.path p) excl; Format.eprintf "@."; *) remove_aliases env excl sg + +(* Restrict a signature to its implicit components. Raises [Not_found] +if references to other elements in the signature cannot be removed. *) +let implicits_only env sg = + let rec extract_implicits_and_module_ids imps mids = function + | [] -> List.rev imps, mids + | Sig_implicit(imp, _) :: rest -> + extract_implicits_and_module_ids (imp :: imps) mids rest + | Sig_module(mid, _, _, _) :: rest -> + extract_implicits_and_module_ids imps (mid :: mids) rest + | _ :: rest -> + extract_implicits_and_module_ids imps mids rest + in + let imps, mids = extract_implicits_and_module_ids [] [] sg in + List.map + (fun imp -> + let imp = + let path = imp.imp_path in + let free = List.exists (fun mid -> Path.isfree mid path) mids in + if free then + let path = Env.normalize_path None env path in + let free = List.exists (fun mid -> Path.isfree mid path) mids in + if free then raise Not_found + else { imp with imp_path = path } + else imp + in + Sig_implicit(imp, Timps_standalone)) + imps diff --git a/typing/mtype.mli b/typing/mtype.mli index 6e815fad89..d11c7378da 100644 --- a/typing/mtype.mli +++ b/typing/mtype.mli @@ -38,3 +38,7 @@ val enrich_typedecl: Env.t -> Path.t -> type_declaration -> type_declaration val type_paths: Env.t -> Path.t -> module_type -> Path.t list val contains_type: Env.t -> module_type -> bool val remove_aliases: Env.t -> module_type -> module_type + +(* Restrict a signature to its implicit components. Raises [Not_found] + if references to other elements in the signature cannot be removed. *) +val implicits_only: Env.t -> signature -> signature diff --git a/typing/oprint.ml b/typing/oprint.ml index 54094593e4..22494c97da 100644 --- a/typing/oprint.ml +++ b/typing/oprint.ml @@ -370,6 +370,19 @@ let out_sig_item = ref (fun _ -> failwith "Oprint.out_sig_item") let out_signature = ref (fun _ -> failwith "Oprint.out_signature") let out_type_extension = ref (fun _ -> failwith "Oprint.out_type_extension") +let print_implicit_flag ppf = function + | Asttypes.Nonimplicit -> () + | Asttypes.Implicit -> fprintf ppf "implicit " + +let print_out_implicit_kind ppf = function + | Oimp_implicit -> fprintf ppf "implicit" + | Oimp_explicit -> fprintf ppf "explicit" + +let print_out_rec_status_module ppf = function + | Orec_not -> fprintf ppf "module" + | Orec_first -> fprintf ppf "module rec" + | Orec_next -> fprintf ppf "and" + let rec print_out_functor ppf = function | Omty_functor (mparam, mty_res) -> @@ -444,15 +457,14 @@ and print_out_sig_item ppf = fprintf ppf "@[<2>module type %s@]" name | Osig_modtype (name, mty) -> fprintf ppf "@[<2>module type %s =@ %a@]" name !out_module_type mty - | Osig_module (name, Omty_alias id, _, _) -> - fprintf ppf "@[<2>module %s =@ %a@]" name print_ident id - | Osig_module (name, mty, rs, i) -> - fprintf ppf "@[<2>%s%s %s :@ %a@]" - (match i with Asttypes.Nonimplicit -> "" - | Asttypes.Implicit -> "implicit ") - (match rs with Orec_not -> "module" - | Orec_first -> "module rec" - | Orec_next -> "and") + | Osig_module (name, Omty_alias id, i, _) -> + fprintf ppf "@[<2>%amodule %s =@ %a@]" + print_implicit_flag i + name print_ident id + | Osig_module (name, mty, i, rs) -> + fprintf ppf "@[<2>%a%a %s :@ %a@]" + print_implicit_flag i + print_out_rec_status_module rs name !out_module_type mty | Osig_type(td, rs) -> print_out_type_decl @@ -469,6 +481,11 @@ and print_out_sig_item ppf = in fprintf ppf "@[<2>%s %a :@ %a%a@]" kwd value_ident name !out_type ty pr_prims prims + | Osig_implicit (kind, name, Oimps_standalone) -> + fprintf ppf "@[<2>%a %a@]" + print_out_implicit_kind kind + print_ident name + | Osig_implicit (kind, name, Oimps_attached) -> () and print_out_type_decl kwd ppf td = let print_constraints ppf = diff --git a/typing/outcometree.mli b/typing/outcometree.mli index 77d6128444..93f1760132 100644 --- a/typing/outcometree.mli +++ b/typing/outcometree.mli @@ -94,9 +94,11 @@ and out_sig_item = out_rec_status | Osig_typext of out_extension_constructor * out_ext_status | Osig_modtype of string * out_module_type - | Osig_module of string * out_module_type * out_rec_status * Asttypes.implicit_flag + | Osig_module of + string * out_module_type * Asttypes.implicit_flag * out_rec_status | Osig_type of out_type_decl * out_rec_status | Osig_value of string * out_type * string list + | Osig_implicit of out_implicit_kind * out_ident * out_imp_status and out_type_decl = { otype_name: string; otype_params: (string * (bool * bool)) list; @@ -115,6 +117,9 @@ and out_type_extension = otyext_params: string list; otyext_constructors: (string * out_type list * out_type option) list; otyext_private: Asttypes.private_flag } +and out_implicit_kind = + | Oimp_implicit + | Oimp_explicit and out_rec_status = | Orec_not | Orec_first @@ -123,6 +128,9 @@ and out_ext_status = | Oext_first | Oext_next | Oext_exception +and out_imp_status = + | Oimps_standalone + | Oimps_attached type out_phrase = | Ophr_eval of out_value * out_type diff --git a/typing/path.ml b/typing/path.ml index 7946ad36e6..a65f97b094 100644 --- a/typing/path.ml +++ b/typing/path.ml @@ -17,6 +17,8 @@ type t = let nopos = -1 +let dummy = Pident Ident.dummy + let rec same p1 p2 = match (p1, p2) with (Pident id1, Pident id2) -> Ident.same id1 id2 @@ -67,6 +69,8 @@ let rec to_longident = function | Papply (p1, p2, i) -> Longident.Lapply (to_longident p1, to_longident p2, i) +let to_string p = Longident.to_string (to_longident p) + let rec flatten acc = function | Pident id -> id, acc | Pdot (p, s, pos) -> flatten ((s,pos) :: acc) p diff --git a/typing/path.mli b/typing/path.mli index a0afe386a4..98b016d095 100644 --- a/typing/path.mli +++ b/typing/path.mli @@ -17,6 +17,7 @@ type t = | Pdot of t * string * int | Papply of t * t * Asttypes.implicit_flag +val dummy: t val same: t -> t -> bool val isfree: Ident.t -> t -> bool val binding_time: t -> int @@ -33,6 +34,8 @@ val head: t -> Ident.t val last: t -> string val to_longident: t -> Longident.t +val to_string: t -> string val flatten: t -> Ident.t * (string * int) list val unflatten: Ident.t -> (string * int) list -> t + diff --git a/typing/printtyp.ml b/typing/printtyp.ml index 8f12e09096..869d908c53 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -1158,6 +1158,18 @@ let tree_of_cltype_declaration id cl rs = let cltype_declaration id ppf cl = !Oprint.out_sig_item ppf (tree_of_cltype_declaration id cl Trec_first) +let tree_of_implicit_kind = function + | Imp_implicit -> Oimp_implicit + | Imp_explicit -> Oimp_explicit + +let implicit_kind ppf = function + | Imp_implicit -> fprintf ppf "implicit" + | Imp_explicit -> fprintf ppf "explicit" + +let tree_of_implicit_status = function + | Timps_standalone -> Oimps_standalone + | Timps_attached -> Oimps_attached + (* Print a module type *) let wrap_env fenv ftree arg = @@ -1198,6 +1210,15 @@ let hide_rec_items = function ids !printing_env) | _ -> () +let tree_of_implicit_description imp is = + let kind = tree_of_implicit_kind imp.imp_kind in + let path = tree_of_path imp.imp_path in + let is = tree_of_implicit_status is in + Osig_implicit (kind, path, is) + +let implicit_description ppf imp = + !Oprint.out_sig_item ppf (tree_of_implicit_description imp Timps_standalone) + let rec tree_of_modtype = function | Mty_ident p -> Omty_ident (tree_of_path p) @@ -1245,15 +1266,17 @@ and tree_of_signature_rec env' = function [Osig_type(tree_of_type_decl id decl, tree_of_rec rs)] | Sig_typext(id, ext, es) -> [tree_of_extension_constructor id ext es] - | Sig_module(id, md, rs) -> + | Sig_module(id, md, is, rs) -> [Osig_module (Ident.name id, tree_of_modtype md.md_type, - tree_of_rec rs, md.md_implicit)] + is, tree_of_rec rs)] | Sig_modtype(id, decl) -> [tree_of_modtype_declaration id decl] | Sig_class(id, decl, rs) -> [tree_of_class_declaration id decl rs] | Sig_class_type(id, decl, rs) -> [tree_of_cltype_declaration id decl rs] + | Sig_implicit(imp, is) -> + [tree_of_implicit_description imp is] in let env' = Env.add_signature (item :: sg) env' in trees @ tree_of_signature_rec env' rem @@ -1267,7 +1290,7 @@ and tree_of_modtype_declaration id decl = Osig_modtype (Ident.name id, mty) let tree_of_module id ?(implicit_ = Nonimplicit) mty rs = - Osig_module (Ident.name id, tree_of_modtype mty, tree_of_rec rs, implicit_) + Osig_module (Ident.name id, tree_of_modtype mty, implicit_, tree_of_rec rs) let modtype ppf mty = !Oprint.out_module_type ppf (tree_of_modtype mty) let modtype_declaration id ppf decl = diff --git a/typing/printtyp.mli b/typing/printtyp.mli index a25bf241e8..8f6982d6ea 100644 --- a/typing/printtyp.mli +++ b/typing/printtyp.mli @@ -50,6 +50,10 @@ val tree_of_extension_constructor: Ident.t -> extension_constructor -> ext_status -> out_sig_item val extension_constructor: Ident.t -> formatter -> extension_constructor -> unit +val tree_of_implicit_description: + implicit_description -> imp_status -> out_sig_item +val implicit_description: + formatter -> implicit_description -> unit val tree_of_module: Ident.t -> ?implicit_:Asttypes.implicit_flag -> module_type -> rec_status -> out_sig_item val modtype: formatter -> module_type -> unit val signature: formatter -> signature -> unit @@ -65,6 +69,7 @@ val class_declaration: Ident.t -> formatter -> class_declaration -> unit val tree_of_cltype_declaration: Ident.t -> class_type_declaration -> rec_status -> out_sig_item val cltype_declaration: Ident.t -> formatter -> class_type_declaration -> unit +val implicit_kind : formatter -> implicit_kind -> unit val type_expansion: type_expr -> Format.formatter -> type_expr -> unit val prepare_expansion: type_expr * type_expr -> type_expr * type_expr val trace: diff --git a/typing/printtyped.ml b/typing/printtyped.ml index 6d7506f735..7130151542 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -95,6 +95,11 @@ let fmt_open_flag f x = | Open_implicit -> fprintf f "Open_implicit"; ;; +let fmt_include_flag f x = + match x with + | Include_all -> fprintf f "Include_all"; + | Include_implicit -> fprintf f "Include_implicit"; +;; let fmt_closed_flag f x = match x with @@ -288,6 +293,10 @@ and expression_extra i ppf x attrs = | Texp_open (ovf, m, _, _) -> line i ppf "Pexp_open %a \"%a\"\n" fmt_open_flag ovf fmt_path m; attributes i ppf attrs; + | Texp_implicit (imp, _) -> + line i ppf "Pexp_implicit \"%a\"\n" fmt_path imp.imp_path; + implicit_kind i ppf imp.imp_kind; + attributes i ppf attrs; | Texp_poly cto -> line i ppf "Pexp_poly\n"; attributes i ppf attrs; @@ -611,6 +620,11 @@ and class_declaration i ppf x = line i ppf "pci_expr =\n"; class_expr (i+1) ppf x.ci_expr; +and implicit_kind i ppf kind = + match kind with + | Timp_implicit -> line i ppf "Pimp_implicit" + | Timp_explicit -> line i ppf "Pimp_explicit" + and module_type i ppf x = line i ppf "module_type %a\n" fmt_location x.mty_loc; attributes i ppf x.mty_attributes; @@ -668,9 +682,14 @@ and signature_item i ppf x = fmt_path od.open_path; attributes i ppf od.open_attributes | Tsig_include incl -> - line i ppf "Psig_include\n"; + line i ppf "Psig_include %a\n" + fmt_include_flag incl.incl_flag; attributes i ppf incl.incl_attributes; module_type i ppf incl.incl_mod + | Tsig_implicit imp -> + line i ppf "Psig_implicit %a\n" fmt_path imp.imp_path; + implicit_kind i ppf imp.imp_kind; + attributes i ppf imp.imp_attributes | Tsig_class (l) -> line i ppf "Psig_class\n"; list i class_description ppf l; @@ -803,9 +822,15 @@ and structure_item i ppf x = line i ppf "Pstr_class_type\n"; list i class_type_declaration ppf (List.map (fun (_, _, cl) -> cl) l); | Tstr_include incl -> - line i ppf "Pstr_include"; + line i ppf "Pstr_include %a" + fmt_include_flag incl.incl_flag; attributes i ppf incl.incl_attributes; module_expr i ppf incl.incl_mod; + | Tstr_implicit imp -> + line i ppf "Pstr_implicit %a\n" + fmt_path imp.imp_path; + implicit_kind i ppf imp.imp_kind; + attributes i ppf imp.imp_attributes | Tstr_attribute (s, arg) -> line i ppf "Pstr_attribute \"%s\"\n" s.txt; Printast.payload i ppf arg diff --git a/typing/subst.ml b/typing/subst.ml index 125c4b56a6..f8f3cc440e 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -316,12 +316,19 @@ let extension_constructor s ext = cleanup_types (); ext +let implicit_description s imp = + { imp_kind = imp.imp_kind; + imp_path = module_path s imp.imp_path; + imp_loc = loc s imp.imp_loc; + imp_attributes = attrs s imp.imp_attributes; + } + let rec rename_bound_idents s idents = function [] -> (List.rev idents, s) | Sig_type(id, d, _) :: sg -> let id' = Ident.rename id in rename_bound_idents (add_type id (Pident id') s) (id' :: idents) sg - | Sig_module(id, mty, _) :: sg -> + | Sig_module(id, mty, _, _) :: sg -> let id' = Ident.rename id in rename_bound_idents (add_module id (Pident id') s) (id' :: idents) sg | Sig_modtype(id, d) :: sg -> @@ -332,6 +339,8 @@ let rec rename_bound_idents s idents = function Sig_class(id, _, _) | Sig_class_type(id, _, _)) :: sg -> let id' = Ident.rename id in rename_bound_idents s (id' :: idents) sg + | Sig_implicit _ :: sg -> + rename_bound_idents s (Ident.dummy :: idents) sg let rec modtype s = function Mty_ident p as mty -> @@ -377,21 +386,22 @@ and signature_component s comp newid = Sig_type(newid, type_declaration s d, rs) | Sig_typext(id, ext, es) -> Sig_typext(newid, extension_constructor s ext, es) - | Sig_module(id, d, rs) -> - Sig_module(newid, module_declaration s d, rs) + | Sig_module(id, d, is, rs) -> + Sig_module(newid, module_declaration s d, is, rs) | Sig_modtype(id, d) -> Sig_modtype(newid, modtype_declaration s d) | Sig_class(id, d, rs) -> Sig_class(newid, class_declaration s d, rs) | Sig_class_type(id, d, rs) -> Sig_class_type(newid, cltype_declaration s d, rs) + | Sig_implicit(imp, is) -> + Sig_implicit(implicit_description s imp, is) and module_declaration s decl = { md_type = modtype s decl.md_type; md_attributes = attrs s decl.md_attributes; md_loc = loc s decl.md_loc; - md_implicit = decl.md_implicit; } and modtype_declaration s decl = diff --git a/typing/subst.mli b/typing/subst.mli index a197f82f48..3a7612af01 100644 --- a/typing/subst.mli +++ b/typing/subst.mli @@ -51,6 +51,7 @@ val modtype: t -> module_type -> module_type val signature: t -> signature -> signature val modtype_declaration: t -> modtype_declaration -> modtype_declaration val module_declaration: t -> module_declaration -> module_declaration +val implicit_description: t -> implicit_description -> implicit_description (* Composition of substitutions: apply (compose s1 s2) x = apply s2 (apply s1 x) *) diff --git a/typing/typecore.ml b/typing/typecore.ml index 98daa6227b..4222ee52fb 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -86,6 +86,11 @@ let type_module = let type_open = ref (fun _ -> assert false) +(* Forward declaration, to be filled in by Typemod.type_implicit *) + +let type_implicit = + ref (fun _ -> assert false) + (* Forward declaration, to be filled in by Typemod.type_package *) let type_package = @@ -144,6 +149,7 @@ let iter_expression f e = | Pexp_record (iel, eo) -> may expr eo; List.iter (fun (_, e) -> expr e) iel | Pexp_open (_, _, e) + | Pexp_implicit (_, e) | Pexp_newtype (_, e) | Pexp_poly (e, _) | Pexp_lazy e @@ -195,6 +201,7 @@ let iter_expression f e = | Pstr_exception _ | Pstr_modtype _ | Pstr_open _ + | Pstr_implicit _ | Pstr_class_type _ | Pstr_attribute _ | Pstr_extension _ -> () @@ -1454,7 +1461,8 @@ and is_nonexpansive_mod mexp = List.for_all (fun item -> match item.str_desc with | Tstr_eval _ | Tstr_primitive _ | Tstr_type _ - | Tstr_modtype _ | Tstr_open _ | Tstr_class_type _ -> true + | Tstr_modtype _ | Tstr_open _ + | Tstr_implicit _ | Tstr_class_type _ -> true | Tstr_value (_, pat_exp_list) -> List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list | Tstr_module {mb_expr=m;_} @@ -2768,6 +2776,14 @@ and type_expect_ ?in_function env sexp ty_expected = sexp.pexp_attributes) :: exp.exp_extra; } + | Pexp_implicit (imp, e) -> + let (imp, _, newenv) = !type_implicit env imp in + let exp = type_expect newenv e ty_expected in + { exp with + exp_extra = (Texp_implicit (imp, newenv), loc, + sexp.pexp_attributes) :: + exp.exp_extra; + } | Pexp_extension ext -> raise (Error_forward (Typetexp.error_of_extension ext)) diff --git a/typing/typecore.mli b/typing/typecore.mli index d701e679e9..04c437c16f 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -129,6 +129,11 @@ val type_module: val type_open: (open_flag -> Env.t -> Location.t -> Longident.t loc -> Path.t * Env.t) ref +(* Forward declaration, to be filled in by Typemod.type_implicit *) +val type_implicit: + (Env.t -> Parsetree.implicit_description -> + Typedtree.implicit_description * Types.implicit_description * Env.t) + ref (* Forward declaration, to be filled in by Typeclass.class_structure *) val type_object: (Env.t -> Location.t -> Parsetree.class_structure -> diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 3402adfd71..c6134a2462 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -66,6 +66,7 @@ and exp_extra = | Texp_constraint of core_type | Texp_coerce of core_type option * core_type | Texp_open of open_flag * Path.t * Longident.t loc * Env.t + | Texp_implicit of implicit_description * Env.t | Texp_poly of core_type option | Texp_newtype of string @@ -235,6 +236,7 @@ and structure_item_desc = | Tstr_class of (class_declaration * string list * virtual_flag) list | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list | Tstr_include of include_declaration + | Tstr_implicit of implicit_description | Tstr_attribute of attribute and module_binding = @@ -300,6 +302,7 @@ and signature_item_desc = | Tsig_modtype of module_type_declaration | Tsig_open of open_description | Tsig_include of include_description + | Tsig_implicit of implicit_description | Tsig_class of class_description list | Tsig_class_type of class_type_declaration list | Tsig_attribute of attribute @@ -332,10 +335,24 @@ and open_description = open_attributes: attribute list; } +and implicit_description = + { + imp_path: Path.t; + imp_txt: Longident.t loc; + imp_kind: implicit_kind; + imp_loc: Location.t; + imp_attributes: attribute list; + } + +and implicit_kind = + | Timp_implicit + | Timp_explicit + and 'a include_infos = { incl_mod: 'a; incl_type: Types.signature; + incl_flag: include_flag; incl_loc: Location.t; incl_attributes: attribute list; } diff --git a/typing/typedtree.mli b/typing/typedtree.mli index b1f95adf52..acddb60d84 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -65,6 +65,7 @@ and exp_extra = | Texp_constraint of core_type | Texp_coerce of core_type option * core_type | Texp_open of open_flag * Path.t * Longident.t loc * Env.t + | Texp_implicit of implicit_description * Env.t | Texp_poly of core_type option | Texp_newtype of string @@ -234,6 +235,7 @@ and structure_item_desc = | Tstr_class of (class_declaration * string list * virtual_flag) list | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list | Tstr_include of include_declaration + | Tstr_implicit of implicit_description | Tstr_attribute of attribute and module_binding = @@ -299,6 +301,7 @@ and signature_item_desc = | Tsig_modtype of module_type_declaration | Tsig_open of open_description | Tsig_include of include_description + | Tsig_implicit of implicit_description | Tsig_class of class_description list | Tsig_class_type of class_type_declaration list | Tsig_attribute of attribute @@ -331,10 +334,24 @@ and open_description = open_attributes: attribute list; } +and implicit_description = + { + imp_path: Path.t; + imp_txt: Longident.t loc; + imp_kind: implicit_kind; + imp_loc: Location.t; + imp_attributes: attribute list; + } + +and implicit_kind = + | Timp_implicit + | Timp_explicit + and 'a include_infos = { incl_mod: 'a; incl_type: Types.signature; + incl_flag: include_flag; incl_loc: Location.t; incl_attributes: attribute list; } diff --git a/typing/typedtreeIter.ml b/typing/typedtreeIter.ml index 50f43d411a..22e434f7dd 100644 --- a/typing/typedtreeIter.ml +++ b/typing/typedtreeIter.ml @@ -140,6 +140,7 @@ module MakeIterator(Iter : IteratorArgument) : sig | Tstr_recmodule list -> List.iter iter_module_binding list | Tstr_modtype mtd -> iter_module_type_declaration mtd | Tstr_open _ -> () + | Tstr_implicit _ -> () | Tstr_class list -> List.iter (fun (ci, _, _) -> iter_class_declaration ci) list | Tstr_class_type list -> @@ -244,6 +245,7 @@ module MakeIterator(Iter : IteratorArgument) : sig | Texp_coerce (cty1, cty2) -> option iter_core_type cty1; iter_core_type cty2 | Texp_open (_, path, _, _) -> () + | Texp_implicit _ -> () | Texp_poly cto -> option iter_core_type cto | Texp_newtype s -> ()) exp.exp_extra; @@ -366,6 +368,7 @@ module MakeIterator(Iter : IteratorArgument) : sig | Tsig_modtype mtd -> iter_module_type_declaration mtd | Tsig_open _ -> () + | Tsig_implicit _ -> () | Tsig_include incl -> iter_module_type incl.incl_mod | Tsig_class list -> List.iter iter_class_description list diff --git a/typing/typedtreeMap.ml b/typing/typedtreeMap.ml index 5cd6471f71..15b2836e9d 100644 --- a/typing/typedtreeMap.ml +++ b/typing/typedtreeMap.ml @@ -131,6 +131,7 @@ module MakeMap(Map : MapArgument) = struct | Tstr_modtype mtd -> Tstr_modtype (map_module_type_declaration mtd) | Tstr_open od -> Tstr_open od + | Tstr_implicit id -> Tstr_implicit id | Tstr_class list -> let list = List.map @@ -382,6 +383,7 @@ module MakeMap(Map : MapArgument) = struct Texp_poly (Some ( map_core_type ct )), loc, attrs | Texp_newtype _ | Texp_open _ + | Texp_implicit _ | Texp_poly None -> exp_extra @@ -418,6 +420,7 @@ module MakeMap(Map : MapArgument) = struct | Tsig_modtype mtd -> Tsig_modtype (map_module_type_declaration mtd) | Tsig_open _ -> item.sig_desc + | Tsig_implicit _ -> item.sig_desc | Tsig_include incl -> Tsig_include {incl with incl_mod = map_module_type incl.incl_mod} | Tsig_class list -> Tsig_class (List.map map_class_description list) diff --git a/typing/typemod.ml b/typing/typemod.ml index 4da99028dc..630f131daa 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -39,6 +39,7 @@ type error = | Scoping_pack of Longident.t * type_expr | Recursive_module_require_explicit_type | Argument_mismatch of module_parameter * module_argument + | Invalid_implicit_include of module_type exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -90,6 +91,74 @@ let type_open ?toplevel env sod = in (path, newenv, od) +let type_open_ ?toplevel opf env loc lid = + let path, md = Typetexp.find_module env lid.loc lid.txt in + let sg = extract_sig_open env lid.loc md.md_type in + let env = match opf with + | Open_all ovf -> Env.open_signature ~loc ?toplevel ovf path sg env + | Open_implicit -> Env.open_implicit path sg env in + path, env + +(* Check that all core type schemes in a structure are closed *) + +let rec closed_modtype = function + Mty_ident p -> true + | Mty_alias p -> true + | Mty_signature sg -> List.for_all closed_signature_item sg + | Mty_functor(param, body) -> closed_modtype body + +and closed_signature_item = function + Sig_value(id, desc) -> Ctype.closed_schema desc.val_type + | Sig_module(id, md, _, _) -> closed_modtype md.md_type + | _ -> true + +let check_nongen_scheme env str = + match str.str_desc with + Tstr_value(rec_flag, pat_exp_list) -> + List.iter + (fun {vb_expr=exp} -> + if not (Ctype.closed_schema exp.exp_type) then + raise(Error(exp.exp_loc, env, Non_generalizable exp.exp_type))) + pat_exp_list + | Tstr_module {mb_expr=md;_} -> + if not (closed_modtype md.mod_type) then + raise(Error(md.mod_loc, env, Non_generalizable_module md.mod_type)) + | _ -> () + +let check_nongen_schemes env str = + List.iter (check_nongen_scheme env) str + +let check_nongen_canonical_path env loc path = + let path = Env.canonical_path env path in + let md = Env.find_module path env in + if not (closed_modtype md.md_type) then + raise(Error(loc, env, Non_generalizable_module md.md_type)) + +let type_implicit env simp = + let tkind, kind = + match simp.pimp_kind with + | Pimp_implicit -> Timp_implicit, Imp_implicit + | Pimp_explicit -> Timp_explicit, Imp_explicit + in + let lid = simp.pimp_lid.Location.txt in + let path = Typetexp.lookup_module ~load:true env simp.pimp_loc lid in + check_nongen_canonical_path env simp.pimp_loc path; + let timp = + {Typedtree. imp_path = path; + imp_txt = simp.pimp_lid; + imp_kind = tkind; + imp_loc = simp.pimp_loc; + imp_attributes = simp.pimp_attributes;} + in + let imp = + {Types. imp_path = path; + imp_kind = kind; + imp_loc = simp.pimp_loc; + imp_attributes = simp.pimp_attributes;} + in + let newenv = Env.add_implicit imp env in + timp, imp, newenv + (* Record a module type *) let rm node = Stypes.record (Stypes.Ti_mod node); @@ -128,8 +197,8 @@ let make_next_first rs rem = match rem with Sig_type (id, decl, Trec_next) :: rem -> Sig_type (id, decl, Trec_first) :: rem - | Sig_module (id, mty, Trec_next) :: rem -> - Sig_module (id, mty, Trec_first) :: rem + | Sig_module (id, mty, is, Trec_next) :: rem -> + Sig_module (id, mty, is, Trec_first) :: rem | _ -> rem else rem @@ -211,15 +280,15 @@ let merge_constraint initial_env loc sg constr = real_id := Some id; (Pident id, lid, Twith_typesubst tdecl), make_next_first rs rem - | (Sig_module(id, md, rs) :: rem, [s], Pwith_module (_, lid')) + | (Sig_module(id, md, is, rs) :: rem, [s], Pwith_module (_, lid')) when Ident.name id = s -> let path, md' = Typetexp.find_module initial_env loc lid'.txt in let md'' = {md' with md_type = Mtype.remove_aliases env md'.md_type} in let newmd = Mtype.strengthen_decl env md'' path in ignore(Includemod.modtypes env newmd.md_type md.md_type); (Pident id, lid, Twith_module (path, lid')), - Sig_module(id, newmd, rs) :: rem - | (Sig_module(id, md, rs) :: rem, [s], Pwith_modsubst (_, lid')) + Sig_module(id, newmd, is, rs) :: rem + | (Sig_module(id, md, is, rs) :: rem, [s], Pwith_modsubst (_, lid')) when Ident.name id = s -> let path, md' = Typetexp.find_module initial_env loc lid'.txt in let newmd = Mtype.strengthen_decl env md' path in @@ -227,12 +296,12 @@ let merge_constraint initial_env loc sg constr = real_id := Some id; (Pident id, lid, Twith_modsubst (path, lid')), make_next_first rs rem - | (Sig_module(id, md, rs) :: rem, s :: namelist, _) + | (Sig_module(id, md, is, rs) :: rem, s :: namelist, _) when Ident.name id = s -> let ((path, path_loc, tcstr), newsg) = merge env (extract_sig env loc md.md_type) namelist None in (path_concat id path, lid, tcstr), - Sig_module(id, {md with md_type=Mty_signature newsg}, rs) :: rem + Sig_module(id, {md with md_type=Mty_signature newsg}, is, rs) :: rem | (item :: rem, _, _) -> let (cstr, items) = merge (Env.add_item item env) rem namelist row_id in @@ -358,7 +427,6 @@ and approx_module_declaration env pmd = Types.md_type = approx_modtype env pmd.pmd_type; md_attributes = pmd.pmd_attributes; md_loc = pmd.pmd_loc; - md_implicit = pmd.pmd_implicit; } and approx_sig env ssg = @@ -375,21 +443,23 @@ and approx_sig env ssg = let (id, newenv) = Env.enter_module_declaration pmd.pmd_name.txt md env in - Sig_module(id, md, Trec_not) :: approx_sig newenv srem + Sig_module(id, md, pmd.pmd_implicit, Trec_not) + :: approx_sig newenv srem | Psig_recmodule sdecls -> let decls = List.map (fun pmd -> (Ident.create pmd.pmd_name.txt, + pmd.pmd_implicit, approx_module_declaration env pmd) ) sdecls in let newenv = List.fold_left - (fun env (id, md) -> Env.add_module_declaration id md env) + (fun env (id, _, md) -> Env.add_module_declaration id md env) env decls in - map_rec (fun rs (id, md) -> Sig_module(id, md, rs)) decls + map_rec (fun rs (id, is, md) -> Sig_module(id, md, is, rs)) decls (approx_sig newenv srem) | Psig_modtype d -> let info = approx_modtype_info env d in @@ -403,6 +473,16 @@ and approx_sig env ssg = let mty = approx_modtype env smty in let sg = Subst.signature Subst.identity (extract_sig env smty.pmty_loc mty) in + let sg = + match sincl.pincl_flag with + | Include_all -> sg + | Include_implicit -> + try + Mtype.implicits_only (Env.add_signature sg env) sg + with Not_found -> + raise(Error(smty.pmty_loc, env, + Invalid_implicit_include mty)) + in let newenv = Env.add_signature sg env in sg @ approx_sig newenv srem | Psig_class sdecls | Psig_class_type sdecls -> @@ -456,7 +536,7 @@ let check_name cl set_ref name = let check_sig_item type_names module_names modtype_names loc = function Sig_type(id, _, _) -> check "type" loc type_names (Ident.name id) - | Sig_module(id, _, _) -> + | Sig_module(id, _, _, _) -> check "module" loc module_names (Ident.name id) | Sig_modtype(id, _) -> check "module type" loc modtype_names (Ident.name id) @@ -645,18 +725,32 @@ and transl_signature env sg = md_type = tmty.mty_type; md_attributes = pmd.pmd_attributes; md_loc = pmd.pmd_loc; - md_implicit = pmd.pmd_implicit; } in let (id, newenv) = Env.enter_module_declaration pmd.pmd_name.txt md env in + let imp, newenv = + match pmd.pmd_implicit with + | Nonimplicit -> [], newenv + | Implicit -> + let path = Pident id in + let imp = + { Types. imp_path = path; + imp_kind = Imp_implicit; + imp_loc = pmd.pmd_loc; + imp_attributes = []; + } + in + let newenv = Env.add_implicit imp newenv in + [Sig_implicit(imp, Timps_attached)], newenv + in let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_module {md_id = id; md_name = pmd.pmd_name; md_type = tmty; md_loc = pmd.pmd_loc; md_implicit = pmd.pmd_implicit; md_attributes = pmd.pmd_attributes}) env loc :: trem, - Sig_module(id, md, Trec_not) :: rem, + Sig_module(id, md, pmd.pmd_implicit, Trec_not) :: (imp @ rem), final_env | Psig_recmodule sdecls -> List.iter @@ -670,9 +764,8 @@ and transl_signature env sg = let d = {Types.md_type = md.md_type.mty_type; md_attributes = md.md_attributes; md_loc = md.md_loc; - md_implicit = md.md_implicit; } in - Sig_module(md.md_id, d, rs)) + Sig_module(md.md_id, d, md.md_implicit, rs)) decls rem, final_env | Psig_modtype pmtd -> @@ -688,12 +781,29 @@ and transl_signature env sg = let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_open od) env loc :: trem, rem, final_env + | Psig_implicit simp -> + let (timp, imp, newenv) = type_implicit env simp in + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_implicit timp) env loc :: trem, + Sig_implicit(imp, Timps_standalone) :: rem, final_env | Psig_include sincl -> let smty = sincl.pincl_mod in let tmty = transl_modtype env smty in let mty = tmty.mty_type in let sg = Subst.signature Subst.identity - (extract_sig env smty.pmty_loc mty) in + (extract_sig env smty.pmty_loc mty) + in + let sg = + match sincl.pincl_flag with + | Include_all -> sg + | Include_implicit -> + try + Mtype.implicits_only (Env.add_signature sg env) sg + with Not_found -> + raise(Error(smty.pmty_loc, env, + Invalid_implicit_include mty)) + + in List.iter (check_sig_item type_names module_names modtype_names item.psig_loc) @@ -702,6 +812,7 @@ and transl_signature env sg = let incl = { incl_mod = tmty; incl_type = sg; + incl_flag = sincl.pincl_flag; incl_attributes = sincl.pincl_attributes; incl_loc = sincl.pincl_loc; } @@ -910,35 +1021,6 @@ let rec path_of_module mexp = path_of_module mexp | _ -> assert false -(* Check that all core type schemes in a structure are closed *) - -let rec closed_modtype = function - Mty_ident p -> true - | Mty_alias p -> true - | Mty_signature sg -> List.for_all closed_signature_item sg - | Mty_functor(param, body) -> closed_modtype body - -and closed_signature_item = function - Sig_value(id, desc) -> Ctype.closed_schema desc.val_type - | Sig_module(id, md, _) -> closed_modtype md.md_type - | _ -> true - -let check_nongen_scheme env str = - match str.str_desc with - Tstr_value(rec_flag, pat_exp_list) -> - List.iter - (fun {vb_expr=exp} -> - if not (Ctype.closed_schema exp.exp_type) then - raise(Error(exp.exp_loc, env, Non_generalizable exp.exp_type))) - pat_exp_list - | Tstr_module {mb_expr=md;_} -> - if not (closed_modtype md.mod_type) then - raise(Error(md.mod_loc, env, Non_generalizable_module md.mod_type)) - | _ -> () - -let check_nongen_schemes env str = - List.iter (check_nongen_scheme env) str - (* Helpers for typing recursive modules *) let anchor_submodule name anchor = @@ -1061,7 +1143,7 @@ let rec package_constraints env loc mty constrs = when List.mem_assoc [Ident.name id] constrs -> let ty = List.assoc [Ident.name id] constrs in Sig_type (id, {td with type_manifest = Some ty}, rs) - | Sig_module (id, md, rs) -> + | Sig_module (id, md, is, rs) -> let rec aux = function | (m :: ((_ :: _) as l), t) :: rest when m = Ident.name id -> (l, t) :: aux rest @@ -1073,7 +1155,7 @@ let rec package_constraints env loc mty constrs = md_type = package_constraints env loc md.md_type (aux constrs) } in - Sig_module (id, md, rs) + Sig_module (id, md, is, rs) | item -> item ) sg @@ -1108,13 +1190,13 @@ let package_subtype env p1 nl1 tl1 p2 nl2 tl2 = let () = Ctype.modtype_of_package := modtype_of_package let () = Ctype.package_subtype := package_subtype -let wrap_constraint env arg mty explicit = +let wrap_constraint env arg mty expl = let coercion = try Includemod.modtypes env arg.mod_type mty with Includemod.Error msg -> raise(Error(arg.mod_loc, env, Not_included msg)) in - { mod_desc = Tmod_constraint(arg, mty, explicit, coercion); + { mod_desc = Tmod_constraint(arg, mty, expl, coercion); mod_type = mty; mod_env = env; mod_attributes = []; @@ -1376,27 +1458,36 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = { md_type = enrich_module_type anchor name.txt modl.mod_type env; md_attributes = attrs; md_loc = pmb_loc; - md_implicit = pmb_implicit; } in let (id, newenv) = Env.enter_module_declaration name.txt md env in - begin match pmb_implicit with - | Nonimplicit -> () - | Implicit -> - if not (closed_modtype modl.mod_type) then - raise(Error(modl.mod_loc, env, - Non_generalizable_module modl.mod_type)) - end; + let imp, newenv = + match pmb_implicit with + | Nonimplicit -> [], newenv + | Implicit -> + if not (closed_modtype modl.mod_type) then + raise(Error(modl.mod_loc, newenv, + Non_generalizable_module modl.mod_type)); + let path = Pident id in + let imp = + { Types. imp_path = path; + imp_kind = Imp_implicit; + imp_loc = pmb_loc; + imp_attributes = []; + } + in + let newenv = Env.add_implicit imp newenv in + [Sig_implicit(imp, Timps_attached)], newenv + in Tstr_module {mb_id = id; mb_name = name; mb_expr = modl; mb_attributes = attrs; mb_loc = pmb_loc; mb_implicit = pmb_implicit; }, - [Sig_module(id, + (Sig_module(id, {md_type = modl.mod_type; md_attributes = attrs; md_loc = pmb_loc; - md_implicit = pmb_implicit; - }, Trec_not)], + }, pmb_implicit, Trec_not)) :: imp, newenv | Pstr_recmodule sbind -> let sbind = @@ -1444,7 +1535,6 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = md_type = md.md_type.mty_type; md_attributes = md.md_attributes; md_loc = md.md_loc; - md_implicit = md.md_implicit; } in Env.add_module_declaration md.md_id mdecl env @@ -1459,8 +1549,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = md_type = mb.mb_expr.mod_type; md_attributes = mb.mb_attributes; md_loc = mb.mb_loc; - md_implicit = mb.mb_implicit; - }, rs)) + }, mb.mb_implicit, rs)) bindings2 [], newenv | Pstr_modtype pmtd -> @@ -1472,6 +1561,9 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = | Pstr_open sod -> let (path, newenv, od) = type_open ~toplevel env sod in Tstr_open od, [], newenv + | Pstr_implicit simp -> + let (timp, imp, newenv) = type_implicit env simp in + Tstr_implicit timp, [Sig_implicit(imp, Timps_standalone)], newenv | Pstr_class cl -> List.iter (fun {pci_name = name} -> check_name "type" type_names name) @@ -1526,6 +1618,16 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = (* Rename all identifiers bound by this signature to avoid clashes *) let sg = Subst.signature Subst.identity (extract_sig_open env smodl.pmod_loc modl.mod_type) in + let sg = + match sincl.pincl_flag with + | Include_all -> sg + | Include_implicit -> + try + Mtype.implicits_only (Env.add_signature sg env) sg + with Not_found -> + raise(Error(smodl.pmod_loc, env, + Invalid_implicit_include modl.mod_type)) + in let sg = match modl.mod_desc with Tmod_ident (p, _) when not (Env.is_functor_arg p env) -> @@ -1533,15 +1635,15 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = let pos = ref 0 in List.map (function - | Sig_module (id, md, rs) -> + | Sig_module (id, md, is, rs) -> let n = !pos in incr pos; Sig_module (id, {md with md_type = Mty_alias (Pdot(p,Ident.name id,n))}, - rs) + is, rs) | Sig_value (_, {val_kind=Val_reg}) | Sig_typext _ | Sig_class _ as it -> incr pos; it - | Sig_value _ | Sig_type _ | Sig_modtype _ + | Sig_value _ | Sig_type _ | Sig_modtype _ | Sig_implicit _ | Sig_class_type _ as it -> it) sg @@ -1553,6 +1655,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = let incl = { incl_mod = modl; incl_type = sg; + incl_flag = sincl.pincl_flag; incl_attributes = sincl.pincl_attributes; incl_loc = sincl.pincl_loc; } @@ -1608,7 +1711,7 @@ and normalize_signature env = List.iter (normalize_signature_item env) and normalize_signature_item env = function Sig_value(id, desc) -> Ctype.normalize_type env desc.val_type - | Sig_module(id, md, _) -> normalize_modtype env md.md_type + | Sig_module(id, md, _, _) -> normalize_modtype env md.md_type | _ -> () (* Extract the module type of a module expression *) @@ -1723,6 +1826,7 @@ let () = Typetexp.transl_modtype_longident := transl_modtype_longident; Typetexp.transl_modtype := transl_modtype; Typecore.type_open := type_open_ ?toplevel:None; + Typecore.type_implicit := type_implicit; Typecore.type_package := type_package; Typeimplicit.type_implicit_instance := type_implicit_instance; type_module_type_of_fwd := type_module_type_of @@ -1819,9 +1923,8 @@ let rec package_signatures subst = function Sig_module(newid, {md_type = Mty_signature sg'; md_attributes = []; md_loc = Location.none; - md_implicit = Nonimplicit; }, - Trec_not) :: + Nonimplicit, Trec_not) :: package_signatures (Subst.add_module oldid (Pident newid) subst) rem let package_units initial_env objfiles cmifile modulename = @@ -1966,6 +2069,12 @@ let report_error ppf = function | Mpar_applicative _, Pmarg_applicative _ -> assert false | Mpar_implicit _, Pmarg_implicit _ -> assert false end + | Invalid_implicit_include mty -> + fprintf ppf + "@[The implicits in@ %a@ \ + contain references to non-implicit components \ + which cannot be removed.@]" modtype mty + let report_error env ppf err = diff --git a/typing/typemod.mli b/typing/typemod.mli index fff10e65d8..549634daab 100644 --- a/typing/typemod.mli +++ b/typing/typemod.mli @@ -66,6 +66,7 @@ type error = | Scoping_pack of Longident.t * type_expr | Recursive_module_require_explicit_type | Argument_mismatch of Types.module_parameter * Parsetree.module_argument + | Invalid_implicit_include of module_type exception Error of Location.t * Env.t * error exception Error_forward of Location.error diff --git a/typing/types.ml b/typing/types.ml index 333d2b125e..603a1ad6dc 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -275,6 +275,17 @@ type class_type_declaration = clty_attributes: Parsetree.attributes; } +type implicit_kind = + | Imp_implicit + | Imp_explicit + +type implicit_description = + { imp_kind : implicit_kind; + imp_path : Path.t; + imp_loc: Location.t; + imp_attributes: Parsetree.attributes; + } + (* Type expressions for the module language *) type module_type = @@ -294,17 +305,17 @@ and signature_item = Sig_value of Ident.t * value_description | Sig_type of Ident.t * type_declaration * rec_status | Sig_typext of Ident.t * extension_constructor * ext_status - | Sig_module of Ident.t * module_declaration * rec_status + | Sig_module of Ident.t * module_declaration * implicit_flag * rec_status | Sig_modtype of Ident.t * modtype_declaration | Sig_class of Ident.t * class_declaration * rec_status | Sig_class_type of Ident.t * class_type_declaration * rec_status + | Sig_implicit of implicit_description * imp_status and module_declaration = { md_type: module_type; md_attributes: Parsetree.attributes; md_loc: Location.t; - md_implicit: implicit_flag; } and modtype_declaration = @@ -323,3 +334,7 @@ and ext_status = Text_first (* first constructor of an extension *) | Text_next (* not first constructor of an extension *) | Text_exception (* an exception *) + +and imp_status = + | Timps_standalone (* A stand-alone implicit statement *) + | Timps_attached (* Part of an implicit module declaration *) diff --git a/typing/types.mli b/typing/types.mli index f3ff943e20..59ea4b6bcf 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -265,6 +265,17 @@ type class_type_declaration = clty_attributes: Parsetree.attributes; } +type implicit_kind = + | Imp_implicit + | Imp_explicit + +type implicit_description = + { imp_kind : implicit_kind; + imp_path : Path.t; + imp_loc: Location.t; + imp_attributes: Parsetree.attributes; + } + (* Type expressions for the module language *) type module_type = @@ -284,17 +295,17 @@ and signature_item = Sig_value of Ident.t * value_description | Sig_type of Ident.t * type_declaration * rec_status | Sig_typext of Ident.t * extension_constructor * ext_status - | Sig_module of Ident.t * module_declaration * rec_status + | Sig_module of Ident.t * module_declaration * implicit_flag * rec_status | Sig_modtype of Ident.t * modtype_declaration | Sig_class of Ident.t * class_declaration * rec_status | Sig_class_type of Ident.t * class_type_declaration * rec_status + | Sig_implicit of implicit_description * imp_status and module_declaration = { md_type: module_type; md_attributes: Parsetree.attributes; md_loc: Location.t; - md_implicit: implicit_flag; } and modtype_declaration = @@ -313,3 +324,7 @@ and ext_status = Text_first (* first constructor in an extension *) | Text_next (* not first constructor in an extension *) | Text_exception + +and imp_status = + | Timps_standalone (* A stand-alone implicit statement *) + | Timps_attached (* Part of an implicit module declaration *) diff --git a/utils/misc.ml b/utils/misc.ml index 898880cb07..71f9c66de8 100644 --- a/utils/misc.ml +++ b/utils/misc.ml @@ -73,6 +73,10 @@ let may_map f = function Some x -> Some (f x) | None -> None +let opt_value = function + | Some x -> x + | None -> assert false + (* File functions *) let find_in_path path name = diff --git a/utils/misc.mli b/utils/misc.mli index 4a3c84b2d9..c9c8abec1a 100644 --- a/utils/misc.mli +++ b/utils/misc.mli @@ -39,6 +39,7 @@ val samelist: ('a -> 'a -> bool) -> 'a list -> 'a list -> bool val may: ('a -> unit) -> 'a option -> unit val may_map: ('a -> 'b) -> 'a option -> 'b option +val opt_value: 'a option -> 'a val find_in_path: string list -> string -> string (* Search a file in a list of directories. *)