From a8659f03a328d3b1a8c6129517853028dac416ee Mon Sep 17 00:00:00 2001 From: Frederic Bour Date: Fri, 12 Dec 2014 11:35:45 +0100 Subject: [PATCH 1/3] Remove test results from git --- .../coercion_arity_mismatch.ml.result | 8 -------- .../typing-modular_implicits/multiple_implicits.ml.result | 4 ---- 2 files changed, 12 deletions(-) delete mode 100644 testsuite/tests/typing-modular_implicits/coercion_arity_mismatch.ml.result delete mode 100644 testsuite/tests/typing-modular_implicits/multiple_implicits.ml.result diff --git a/testsuite/tests/typing-modular_implicits/coercion_arity_mismatch.ml.result b/testsuite/tests/typing-modular_implicits/coercion_arity_mismatch.ml.result deleted file mode 100644 index ce013b13d3..0000000000 --- a/testsuite/tests/typing-modular_implicits/coercion_arity_mismatch.ml.result +++ /dev/null @@ -1,8 +0,0 @@ - -# module type S = sig type t end -# module type T = sig type _ t end -# M# let f (x : (implicit X:S) -> X.t) () = (x :> (implicit X:T) -> unit X.t);; -Error: Type (implicit X : S) -> X.t is not a subtype of - (implicit X : T) -> unit X.t - Type (module T) is not a subtype of (module S) -# diff --git a/testsuite/tests/typing-modular_implicits/multiple_implicits.ml.result b/testsuite/tests/typing-modular_implicits/multiple_implicits.ml.result deleted file mode 100644 index 76dc0dff1c..0000000000 --- a/testsuite/tests/typing-modular_implicits/multiple_implicits.ml.result +++ /dev/null @@ -1,4 +0,0 @@ - -# module type T = sig type a end -# val f : (implicit A : T) -> (implicit B : T) -> A.a * B.a -> unit = -# From 3cfd9b39d5b0af02fcafbbf4c3e2dfe6ac6751f7 Mon Sep 17 00:00:00 2001 From: Frederic Bour Date: Fri, 12 Dec 2014 11:35:58 +0100 Subject: [PATCH 2/3] Introduce "implicit Path" construction --- bytecomp/translmod.ml | 14 +++++++++--- ocamldoc/odoc_ast.ml | 2 ++ ocamldoc/odoc_env.ml | 1 + ocamldoc/odoc_sig.ml | 5 +++- parsing/ast_helper.ml | 12 ++++++++++ parsing/ast_helper.mli | 8 +++++++ parsing/ast_mapper.ml | 11 +++++++++ parsing/ast_mapper.mli | 1 + parsing/longident.ml | 5 ++++ parsing/longident.mli | 2 ++ parsing/parsetree.mli | 12 ++++++++++ parsing/pprintast.ml | 10 ++++++++ parsing/printast.ml | 8 +++++++ tools/depend.ml | 4 ++++ tools/tast_iter.ml | 2 ++ tools/untypeast.ml | 10 ++++++++ typing/btype.ml | 1 + typing/env.ml | 49 +++++++++++++++++++++++++++++++++++++--- typing/env.mli | 4 ++++ typing/implicitsearch.ml | 30 +++--------------------- typing/includemod.ml | 7 +++++- typing/mtype.ml | 22 +++++++++++++++--- typing/oprint.ml | 5 ++++ typing/outcometree.mli | 1 + typing/path.ml | 1 + typing/path.mli | 2 ++ typing/printtyp.ml | 2 ++ typing/printtyped.ml | 8 +++++++ typing/subst.ml | 5 ++++ typing/typecore.ml | 6 +++-- typing/typedtree.ml | 11 +++++++++ typing/typedtree.mli | 11 +++++++++ typing/typedtreeIter.ml | 2 ++ typing/typedtreeMap.ml | 2 ++ typing/typemod.ml | 36 +++++++++++++++++++++++++++-- typing/types.ml | 1 + typing/types.mli | 1 + 37 files changed, 272 insertions(+), 42 deletions(-) diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index dc7d2d7a63..c43dfe4377 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -220,6 +220,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, @@ -378,8 +380,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 @@ -438,6 +440,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 @@ -488,7 +491,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 *) @@ -512,6 +516,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 [] -> [] @@ -539,6 +544,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 @@ -655,6 +661,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 @@ -852,6 +859,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 6c156d7f64..afe91ddd21 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 _ -> () @@ -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 3e05905856..ef24b0b105 100644 --- a/ocamldoc/odoc_env.ml +++ b/ocamldoc/odoc_env.ml @@ -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 b584acaa46..ebf6baeb75 100644 --- a/ocamldoc/odoc_sig.ml +++ b/ocamldoc/odoc_sig.ml @@ -60,6 +60,8 @@ module Signature_search = 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 @@ -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 ffab29ae62..379699ab4b 100644 --- a/parsing/ast_helper.ml +++ b/parsing/ast_helper.ml @@ -164,6 +164,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) @@ -184,6 +185,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) @@ -331,6 +333,16 @@ module Opn = struct } end +module Imp = struct + let mk ?(loc = !default_loc) ?(attrs = []) ?(arity = 0) lid = + { + pimp_lid = lid; + pimp_loc = loc; + pimp_attributes = attrs; + pimp_arity = arity; + } +end + module Incl = struct let mk ?(loc = !default_loc) ?(attrs = []) mexpr = { diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli index edfec8fc21..c571d35d20 100644 --- a/parsing/ast_helper.mli +++ b/parsing/ast_helper.mli @@ -216,6 +216,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 @@ -238,6 +239,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 @@ -271,6 +273,12 @@ 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 -> ?arity:int -> lid -> implicit_description + end + (* Includes *) module Incl: sig diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index 24565f74de..6e01a94c5f 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; @@ -252,6 +253,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 @@ -299,6 +302,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 @@ -562,6 +566,13 @@ let default_mapper = ~attrs:(this.attributes this pincl_attributes) ); + implicit_description = + (fun this {pimp_lid; pimp_arity; pimp_attributes; pimp_loc} -> + Imp.mk (map_loc this pimp_lid) + ~arity:pimp_arity + ~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/longident.ml b/parsing/longident.ml index 706881af3a..195045a986 100644 --- a/parsing/longident.ml +++ b/parsing/longident.ml @@ -39,3 +39,8 @@ 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) -> to_string t1 ^ "(" ^ to_string t2 ^ ")" diff --git a/parsing/longident.mli b/parsing/longident.mli index 9e7958550c..599b1aa703 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/parsetree.mli b/parsing/parsetree.mli index a96fd245fb..19fdfbef24 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -681,6 +681,8 @@ and signature_item_desc = (* [@@@id] *) | Psig_extension of extension * attributes (* [%%id] *) + | Psig_implicit of implicit_description + (* implicit Path *) and module_declaration = { @@ -715,6 +717,14 @@ and open_description = open X - popen_override = Fresh *) +and implicit_description = + { + pimp_lid: Longident.t loc; + pimp_loc: Location.t; + pimp_attributes: attributes; + pimp_arity: int; + } + and 'a include_infos = { pincl_mod: 'a; @@ -808,6 +818,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 0288589b43..7844eb587c 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -1056,6 +1056,12 @@ class printer ()= object(self:'self) | Psig_extension(e, a) -> self#item_extension f e; self#item_attributes f a + | Psig_implicit id -> + (*FIXME Arity*) + pp f "@[implicit@ %a@]%a" + self#longident_loc id.pimp_lid + self#item_attributes id.pimp_attributes + end method module_expr f x = if x.pmod_attributes <> [] then begin @@ -1272,6 +1278,10 @@ class printer ()= object(self:'self) | Pstr_extension(e, a) -> self#item_extension f e; self#item_attributes f a + | Pstr_implicit id -> + pp f "@[implicit@ %a@]%a" + self#longident_loc id.pimp_lid + self#item_attributes id.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 1f57806a9a..68915dd1bd 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -707,6 +707,10 @@ 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 id -> + line i ppf "Psig_implicit %a %d\n" + fmt_longident_loc id.pimp_lid id.pimp_arity; + attributes i ppf id.pimp_attributes and modtype_declaration i ppf = function | None -> line i ppf "#abstract" @@ -814,6 +818,10 @@ 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 id -> + line i ppf "Pstr_implicit %a %d\n" + fmt_longident_loc id.pimp_lid id.pimp_arity; + attributes i ppf id.pimp_attributes and module_declaration i ppf pmd = string_loc i ppf pmd.pmd_name; diff --git a/tools/depend.ml b/tools/depend.ml index 921f535658..ba9a29f12c 100644 --- a/tools/depend.ml +++ b/tools/depend.ml @@ -267,6 +267,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 id -> + addmodule bv id.pimp_lid; bv | Psig_attribute _ | Psig_extension _ -> bv @@ -328,6 +330,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/tast_iter.ml b/tools/tast_iter.ml index 1b62436771..69fd5c4742 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 -> @@ -192,6 +193,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 16433ca7ab..d8be2e32ae 100644 --- a/tools/untypeast.ml +++ b/tools/untypeast.ml @@ -71,6 +71,11 @@ and untype_structure_item item = popen_attributes = od.open_attributes; popen_loc = od.open_loc; } + | Tstr_implicit imp -> + Pstr_implicit {pimp_lid = imp.imp_txt; pimp_arity = imp.imp_arity; + pimp_attributes = imp.imp_attributes; + pimp_loc = imp.imp_loc; + } | Tstr_class list -> Pstr_class (List.map @@ -414,6 +419,11 @@ and untype_signature_item item = popen_attributes = od.open_attributes; popen_loc = od.open_loc; } + | Tsig_implicit imp -> + Psig_implicit {pimp_lid = imp.imp_txt; pimp_arity = imp.imp_arity; + pimp_attributes = imp.imp_attributes; + pimp_loc = imp.imp_loc; + } | Tsig_include incl -> Psig_include {pincl_mod = untype_module_type incl.incl_mod; pincl_attributes = incl.incl_attributes; diff --git a/typing/btype.ml b/typing/btype.ml index 16fa60b268..6d77ed4113 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -264,6 +264,7 @@ let type_iterators = | 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 = diff --git a/typing/env.ml b/typing/env.ml index 67bbb4b641..9f3fb28a71 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -646,6 +646,12 @@ let rec implicit_cannot_occur path env = let implicit_instances env = env.implicit_instances +let register_as_implicit path arity env = + let md = find_module path env in + let md = {md with md_implicit = Implicit arity} in + (* FIXME: Check arity *) + register_if_implicit path md env + (* Lookup by name *) exception Recmodule @@ -1098,6 +1104,32 @@ let rec scrape_alias env ?path mty = let scrape_alias env mty = scrape_alias env mty +(* Follow all aliases in a 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,i) -> + let p1' = canonical_path env p1 in + if p1 == p1' then + path + else + Path.Pdot (p1', s, i) + | Path.Papply (p1, p2) -> + 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') + with Not_found -> + (*?!*) + path + (* Compute constructor descriptions *) let constructors_of_type ty_path decl = @@ -1132,24 +1164,29 @@ 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_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_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 -> + prefix_idents root pos sub rem | item :: rem -> let id = signature_item_ident item in let size = signature_item_size item in @@ -1178,6 +1215,8 @@ let subst_signature sub sg = 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(path, arity) -> + Sig_implicit(Subst.module_path sub path, arity) ) sg @@ -1285,7 +1324,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_arg, ty_res) -> @@ -1565,6 +1605,7 @@ let add_item comp 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(path, arity) -> register_as_implicit path arity env let rec add_signature sg env = match sg with @@ -1598,6 +1639,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(path, arity) -> + register_as_implicit path arity env ) env0 sg pl in { newenv with summary = Env_open(env0.summary, root) } diff --git a/typing/env.mli b/typing/env.mli index 9fad70912c..33ec30eb89 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -133,6 +133,9 @@ val open_pers_signature: string -> t -> t val open_implicit: Path.t -> signature -> t -> t +(* Mark one path as implicit *) +val register_as_implicit: Path.t -> int -> t -> t + (* Insertion by name *) val enter_value: @@ -266,3 +269,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/implicitsearch.ml b/typing/implicitsearch.ml index 64be2630fc..118314959e 100644 --- a/typing/implicitsearch.ml +++ b/typing/implicitsearch.ml @@ -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) -> @@ -1030,30 +1030,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,i) -> - let p1' = canonical_path env p1 in - if p1 == p1' then - path - else - Path.Pdot (p1', s, i) - | Path.Papply (p1, p2) -> - 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') - with Not_found -> - (*?!*) - path - let find_pending_instance inst = let snapshot = Btype.snapshot () in let vars, target = target_of_pending inst in @@ -1081,14 +1057,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 336596a4ed..9dc9e52c2f 100644 --- a/typing/includemod.ml +++ b/typing/includemod.ml @@ -157,11 +157,13 @@ let item_ident_name = function | 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(_,_,_) @@ -302,6 +304,7 @@ and signatures env cxt subst sig1 sig2 = The table is indexed by kind and name of component *) let rec build_component_table pos tbl = function [] -> pos, tbl + | Sig_implicit _ :: rem -> build_component_table pos tbl 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 @@ -333,6 +336,8 @@ and signatures env cxt subst sig1 sig2 = Tcoerce_structure (cc, id_pos_list) | _ -> raise(Error unpaired) end + | Sig_implicit _ :: rem -> + pair_components subst paired unpaired rem | item2 :: rem -> let (id2, loc, name2) = item_ident_name item2 in let name2, report = @@ -355,7 +360,7 @@ 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 diff --git a/typing/mtype.ml b/typing/mtype.ml index 776b622166..0b3b9023a1 100644 --- a/typing/mtype.ml +++ b/typing/mtype.ml @@ -82,6 +82,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} @@ -96,6 +98,16 @@ type variance = Co | Contra | Strict let nondep_supertype env mid mty = + let nondep_alias env p = + if Path.isfree mid p then + let p = Env.canonical_path env p in + if Path.isfree mid p then + (* FIXME: do better *) + failwith "Path would escape" + else p + else p + in + let rec nondep_mty env va mty = match mty with Mty_ident p -> @@ -149,6 +161,9 @@ 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 (path, arity) -> + Sig_implicit (nondep_alias env path, arity) + :: rem' and nondep_modtype_decl env mtd = {mtd with mtd_type = Misc.may_map (nondep_mty env Strict) mtd.mtd_type} @@ -210,7 +225,7 @@ and type_paths_sig env p pos sg = 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 = @@ -231,7 +246,7 @@ and no_code_needed_sig env sg = | 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 @@ -266,7 +281,8 @@ and contains_type_item env = function | Sig_type _ | Sig_typext _ | Sig_class _ - | Sig_class_type _ -> + | Sig_class_type _ + | Sig_implicit _-> () let contains_type env mty = diff --git a/typing/oprint.ml b/typing/oprint.ml index effda5ad32..26275a41f2 100644 --- a/typing/oprint.ml +++ b/typing/oprint.ml @@ -482,6 +482,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 (name, arity) -> + print_ident ppf name; + for _i = 1 to arity do + pp_print_string ppf "(_)" + done and print_out_type_decl kwd ppf td = let print_constraints ppf = diff --git a/typing/outcometree.mli b/typing/outcometree.mli index fc991bcad0..3eeda499f1 100644 --- a/typing/outcometree.mli +++ b/typing/outcometree.mli @@ -93,6 +93,7 @@ and out_sig_item = | Osig_module of string * out_module_type * out_rec_status * Asttypes.implicit_flag | Osig_type of out_type_decl * out_rec_status | Osig_value of string * out_type * string list + | Osig_implicit of out_ident * int and out_type_decl = { otype_name: string; otype_params: (string * (bool * bool)) list; diff --git a/typing/path.ml b/typing/path.ml index 90ae0ba61c..73c82876c5 100644 --- a/typing/path.ml +++ b/typing/path.ml @@ -62,6 +62,7 @@ let rec to_longident = function | Pident id -> Longident.Lident (Ident.name id) | Pdot(p, s, _) -> Longident.Ldot (to_longident p, s) | Papply (p1, p2) -> Longident.Lapply (to_longident p1, to_longident p2) +let to_string p = Longident.to_string (to_longident p) let rec flatten acc = function | Pident id -> id, acc diff --git a/typing/path.mli b/typing/path.mli index b27dd4cbb3..cb78b8115f 100644 --- a/typing/path.mli +++ b/typing/path.mli @@ -33,6 +33,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 6724d9ea16..e81786c86b 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -1236,6 +1236,8 @@ and tree_of_signature_rec env' = function [tree_of_class_declaration id decl rs] | Sig_class_type(id, decl, rs) -> [tree_of_cltype_declaration id decl rs] + | Sig_implicit(path, arity) -> + [Osig_implicit (tree_of_path path, arity)] in let env' = Env.add_signature (item :: sg) env' in trees @ tree_of_signature_rec env' rem diff --git a/typing/printtyped.ml b/typing/printtyped.ml index 8d4977399d..a9f0489d81 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -666,6 +666,10 @@ and signature_item i ppf x = line i ppf "Psig_include\n"; attributes i ppf incl.incl_attributes; module_type i ppf incl.incl_mod + | Tsig_implicit imp -> + line i ppf "Psig_implicit %a %d\n" + fmt_path imp.imp_path imp.imp_arity; + attributes i ppf imp.imp_attributes | Tsig_class (l) -> line i ppf "Psig_class\n"; list i class_description ppf l; @@ -779,6 +783,10 @@ and structure_item i ppf x = line i ppf "Pstr_include"; attributes i ppf incl.incl_attributes; module_expr i ppf incl.incl_mod; + | Tstr_implicit imp -> + line i ppf "Pstr_implicit %a %d\n" + fmt_path imp.imp_path imp.imp_arity; + 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 ceaca044fa..97549ca483 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -332,6 +332,10 @@ 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 (path,_) :: sg -> + (* Ugly: Put a fake identifier *) + let id' = Path.head path in + rename_bound_idents s (id' :: idents) sg let rec modtype s = function Mty_ident p as mty -> @@ -376,6 +380,7 @@ and signature_component s comp newid = 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 _ as sgi -> sgi and module_declaration s decl = { diff --git a/typing/typecore.ml b/typing/typecore.ml index 2328958f24..d3e0621afc 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -192,6 +192,7 @@ let iter_expression f e = | Pstr_exception _ | Pstr_modtype _ | Pstr_open _ + | Pstr_implicit _ | Pstr_class_type _ | Pstr_attribute _ | Pstr_extension _ -> () @@ -1451,7 +1452,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;_} @@ -2584,7 +2586,7 @@ and type_expect_ ?in_function env sexp ty_expected = Ident.set_current_time ty.level; let context = Typetexp.narrow () in let implicit_arity = match pmb_implicit with - | Nonimplicit -> 0 + | Nonimplicit -> 0 | Implicit ar -> ar in let modl = !type_module ~implicit_arity env smodl in diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 02642850ba..d2d2b8f4c2 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -225,6 +225,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 = @@ -290,6 +291,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 @@ -322,6 +324,15 @@ and open_description = open_attributes: attribute list; } +and implicit_description = + { + imp_path: Path.t; + imp_txt: Longident.t loc; + imp_arity: int; + imp_loc: Location.t; + imp_attributes: attribute list; + } + and 'a include_infos = { incl_mod: 'a; diff --git a/typing/typedtree.mli b/typing/typedtree.mli index aafa2f778e..20b91160b9 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -224,6 +224,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 = @@ -289,6 +290,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 @@ -321,6 +323,15 @@ and open_description = open_attributes: attribute list; } +and implicit_description = + { + imp_path: Path.t; + imp_txt: Longident.t loc; + imp_arity: int; + imp_loc: Location.t; + imp_attributes: attribute list; + } + and 'a include_infos = { incl_mod: 'a; diff --git a/typing/typedtreeIter.ml b/typing/typedtreeIter.ml index 7ac879ed55..a04fc419ea 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 -> @@ -366,6 +367,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 44abc5b834..a3e58c17a3 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 @@ -418,6 +419,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 87d88ef59f..400cbda0dd 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -90,6 +90,30 @@ let type_open ?toplevel env sod = in (path, newenv, od) +let type_implicit env id = + let arity = id.pimp_arity in + let lid = id.pimp_lid.Location.txt in + let path = Env.lookup_module ~load:true lid env in + (* FIXME: Check that arity match *) + let newenv = Env.register_as_implicit path arity env in + let imp = {Typedtree. imp_path = path; + imp_txt = id.pimp_lid; + imp_loc = id.pimp_loc; + imp_attributes = id.pimp_attributes; + imp_arity = arity} + in + path, arity, newenv, imp + +(* Bind a module as implicit in current environment *) + +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 + (* Record a module type *) let rm node = Stypes.record (Stypes.Ti_mod node); @@ -656,6 +680,11 @@ 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 id -> + let (path, arity, newenv, imp) = type_implicit env id in + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_implicit imp) env loc :: trem, + Sig_implicit (path, arity) :: rem, final_env | Psig_include sincl -> let smty = sincl.pincl_mod in let tmty = transl_modtype env smty in @@ -1281,7 +1310,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = } -> check_name "module" module_names name; let implicit_arity = match pmb_implicit with - | Nonimplicit -> 0 + | Nonimplicit -> 0 | Implicit ar -> ar in let modl = @@ -1387,6 +1416,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 id -> + let (path, arity, newenv, imp) = type_implicit env id in + Tstr_implicit imp, [], newenv | Pstr_class cl -> List.iter (fun {pci_name = name} -> check_name "type" type_names name) @@ -1456,7 +1488,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = | 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 diff --git a/typing/types.ml b/typing/types.ml index 0535e850ca..4b0fc8ea0b 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -293,6 +293,7 @@ and signature_item = | 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 Path.t * int and module_declaration = { diff --git a/typing/types.mli b/typing/types.mli index 06064032e5..524d01df39 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -283,6 +283,7 @@ and signature_item = | 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 Path.t * int and module_declaration = { From de76fe854f24521d9f575cba26a184434688164a Mon Sep 17 00:00:00 2001 From: Frederic Bour Date: Fri, 12 Dec 2014 11:53:18 +0100 Subject: [PATCH 3/3] Add implicit statements in surface language --- parsing/parser.mly | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/parsing/parser.mly b/parsing/parser.mly index 38b26ee0cb..927fce886b 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -660,6 +660,7 @@ 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) } | IMPLICIT implicit_binding { mkstr(Pstr_module $2) } | CLASS class_declarations @@ -690,6 +691,14 @@ module_binding: { Mb.mk (mkrhs $1 1) $2 ~attrs:$3 ~loc:(symbol_rloc ()) } ; +implicit_statement: + | IMPLICIT mod_longident implicit_statement_arity post_item_attributes + { Imp.mk (mkrhs $2 2) ~arity:$3 ~attrs:$4 ~loc:(symbol_rloc()) } +; +implicit_statement_arity: + | /* empty */ { 0 } + | implicit_statement_arity LPAREN UNDERSCORE RPAREN { 1 + $1 } +; implicit_parameter: | LPAREN functor_arg_name COLON module_type RPAREN @@ -799,6 +808,8 @@ signature_item: ~attrs:$6)) } | open_statement { mksig(Psig_open $1) } + | implicit_statement + { mksig(Psig_implicit $1) } | INCLUDE module_type post_item_attributes %prec below_WITH { mksig(Psig_include (Incl.mk $2 ~attrs:$3 ~loc:(symbol_rloc()))) } | CLASS class_descriptions