From 803b2c5d01e6a9bd473cb1764f1e08206bdb18c2 Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Sat, 8 Apr 2017 20:53:27 -0700 Subject: [PATCH 01/39] Extend `open`. Signed-off-by: Runhang Li --- driver/compmisc.ml | 7 +- ocamldoc/odoc_analyse.ml | 8 +- parsing/ast_helper.ml | 4 +- parsing/ast_helper.mli | 6 +- parsing/ast_invariants.ml | 2 +- parsing/ast_iterator.ml | 4 +- parsing/ast_mapper.ml | 4 +- parsing/depend.ml | 10 +- parsing/parser.mly | 4 +- parsing/parsetree.mli | 2 +- parsing/pprintast.ml | 4 +- parsing/printast.ml | 8 +- .../parsing/shortcut_ext_attr.ml.reference | 10 +- testsuite/tests/typing-modules/open-struct.ml | 101 +++++++++ typing/printtyped.ml | 18 +- typing/tast_mapper.ml | 12 +- typing/typecore.ml | 17 +- typing/typecore.mli | 2 +- typing/typedtree.ml | 7 +- typing/typedtree.mli | 7 +- typing/typemod.ml | 205 +++++++++++++++--- typing/typemod.mli | 7 +- typing/untypeast.ml | 4 +- 23 files changed, 364 insertions(+), 89 deletions(-) create mode 100644 testsuite/tests/typing-modules/open-struct.ml diff --git a/driver/compmisc.ml b/driver/compmisc.ml index 47f69077a4a8..4f075f98826d 100644 --- a/driver/compmisc.ml +++ b/driver/compmisc.ml @@ -43,9 +43,10 @@ let init_path ?(dir="") native = let open_implicit_module m env = let open Asttypes in - let lid = {loc = Location.in_file "command line"; - txt = Longident.parse m } in - snd (Typemod.type_open_ Override env lid.loc lid) + let loc = Location.in_file "command line" in + let lid = {loc; txt = Longident.parse m } in + let me = Parsetree.({pmod_desc=Pmod_ident lid; pmod_loc=loc; pmod_attributes=[]}) in + snd (Typemod.type_open_ ?toplevel:None false Override env lid.loc me) let initial_env () = Ident.reinit(); diff --git a/ocamldoc/odoc_analyse.ml b/ocamldoc/odoc_analyse.ml index 2e0657bfd3e7..2fe3ce77c3b6 100644 --- a/ocamldoc/odoc_analyse.ml +++ b/ocamldoc/odoc_analyse.ml @@ -39,9 +39,11 @@ let initial_env () = in let open_mod env m = let open Asttypes in - let lid = {loc = Location.in_file "ocamldoc command line"; - txt = Longident.parse m } in - snd (Typemod.type_open_ Override env lid.loc lid) in + let loc = Location.in_file "ocamldoc command line" in + let lid = {loc; txt = Longident.parse m } in + let me = Parsetree.({pmod_desc=Pmod_ident lid; + pmod_loc=loc; pmod_attributes=[]}) in + snd (Typemod.type_open_ ?toplevel:None false Override env lid.loc me) in (* Open the list of modules given as arguments of the "-open" flag The list is reversed to open the modules in the left-to-right order *) let to_open = List.rev !Clflags.open_modules in diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml index ac1fc40da5ce..29dfe3b47b57 100644 --- a/parsing/ast_helper.ml +++ b/parsing/ast_helper.ml @@ -407,9 +407,9 @@ end module Opn = struct let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(override = Fresh) lid = + ?(override = Fresh) expr = { - popen_lid = lid; + popen_expr = expr; popen_override = override; popen_loc = loc; popen_attributes = add_docs_attrs docs attrs; diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli index 0a216bdb56ea..022a543508ef 100644 --- a/parsing/ast_helper.mli +++ b/parsing/ast_helper.mli @@ -169,8 +169,8 @@ module Exp: val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression - val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> expression - -> expression + val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid + -> expression -> expression val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression @@ -323,7 +323,7 @@ module Mb: module Opn: sig val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> - ?override:override_flag -> lid -> open_description + ?override:override_flag -> module_expr -> open_description end (** Includes *) diff --git a/parsing/ast_invariants.ml b/parsing/ast_invariants.ml index 31ee17eb9b30..834a792ddcb9 100644 --- a/parsing/ast_invariants.ml +++ b/parsing/ast_invariants.ml @@ -117,7 +117,7 @@ let iterator = in let open_description self opn = super.open_description self opn; - simple_longident opn.popen_lid + super.module_expr self opn.popen_expr in let with_constraint self wc = super.with_constraint self wc; diff --git a/parsing/ast_iterator.ml b/parsing/ast_iterator.ml index 8518438d829c..479ba62a996b 100755 --- a/parsing/ast_iterator.ml +++ b/parsing/ast_iterator.ml @@ -526,8 +526,8 @@ let default_iterator = open_description = - (fun this {popen_lid; popen_override = _; popen_attributes; popen_loc} -> - iter_loc this popen_lid; + (fun this {popen_expr; popen_override = _; popen_attributes; popen_loc} -> + this.module_expr this popen_expr; this.location this popen_loc; this.attributes this popen_attributes ); diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index 4962cc2cdbdf..5232efd6e7ef 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -561,8 +561,8 @@ let default_mapper = open_description = - (fun this {popen_lid; popen_override; popen_attributes; popen_loc} -> - Opn.mk (map_loc this popen_lid) + (fun this {popen_expr; popen_override; popen_attributes; popen_loc} -> + Opn.mk (this.module_expr this popen_expr) ~override:popen_override ~loc:(this.location this popen_loc) ~attrs:(this.attributes this popen_attributes) diff --git a/parsing/depend.ml b/parsing/depend.ml index 8703ffe0199f..de666323b995 100644 --- a/parsing/depend.ml +++ b/parsing/depend.ml @@ -363,7 +363,10 @@ and add_sig_item (bv, m) item = end; (bv, m) | Psig_open od -> - (open_module bv od.popen_lid.txt, m) + let Node (s, m') = add_module_binding bv od.popen_expr in + add_names s; + let add = StringMap.fold StringMap.add m' in + (add bv, add m) | Psig_include incl -> let Node (s, m') = add_modtype_binding bv incl.pincl_mod in add_names s; @@ -454,7 +457,10 @@ and add_struct_item (bv, m) item : _ StringMap.t * _ StringMap.t = end; (bv, m) | Pstr_open od -> - (open_module bv od.popen_lid.txt, m) + let Node (s, m') = add_module_binding bv od.popen_expr in + add_names s; + let add = StringMap.fold StringMap.add m' in + (add bv, add m) | Pstr_class cdl -> List.iter (add_class_declaration bv) cdl; (bv, m) | Pstr_class_type cdtl -> diff --git a/parsing/parser.mly b/parsing/parser.mly index 2dc49aa420a2..58b95c29aa2b 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -917,9 +917,9 @@ signature_item: mksig(Psig_attribute $1) } ; open_statement: - | OPEN override_flag ext_attributes mod_longident post_item_attributes + | OPEN override_flag ext_attributes module_expr post_item_attributes { let (ext, attrs) = $3 in - Opn.mk (mkrhs $4 4) ~override:$2 ~attrs:(attrs@$5) + Opn.mk $4 ~override:$2 ~attrs:(attrs@$5) ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) , ext} ; diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index 1155ddc9ec0f..a1029ce15a10 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -727,7 +727,7 @@ and module_type_declaration = and open_description = { - popen_lid: Longident.t loc; + popen_expr: module_expr; popen_override: override_flag; popen_loc: Location.t; popen_attributes: attributes; diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index ff352c576c6d..4eb2afb552b2 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -989,7 +989,7 @@ and signature_item ctxt f x : unit = | Psig_open od -> pp f "@[open%s@ %a@]%a" (override od.popen_override) - longident_loc od.popen_lid + (module_expr ctxt) od.popen_expr (item_attributes ctxt) od.popen_attributes | Psig_include incl -> pp f "@[include@ %a@]%a" @@ -1187,7 +1187,7 @@ and structure_item ctxt f x = | Pstr_open od -> pp f "@[<2>open%s@;%a@]%a" (override od.popen_override) - longident_loc od.popen_lid + (module_expr ctxt) od.popen_expr (item_attributes ctxt) od.popen_attributes | Pstr_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> pp f "@[module@ type@ %s%a@]%a" diff --git a/parsing/printast.ml b/parsing/printast.ml index 6e167b3e47be..94d9d4197015 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -680,9 +680,9 @@ and signature_item i ppf x = attributes i ppf x.pmtd_attributes; modtype_declaration i ppf x.pmtd_type | Psig_open od -> - line i ppf "Psig_open %a %a\n" + line i ppf "Psig_open %a\n%a\n" fmt_override_flag od.popen_override - fmt_longident_loc od.popen_lid; + (module_expr i) od.popen_expr; attributes i ppf od.popen_attributes | Psig_include incl -> line i ppf "Psig_include\n"; @@ -787,9 +787,9 @@ and structure_item i ppf x = attributes i ppf x.pmtd_attributes; modtype_declaration i ppf x.pmtd_type | Pstr_open od -> - line i ppf "Pstr_open %a %a\n" + line i ppf "Pstr_open %a\n%a\n" fmt_override_flag od.popen_override - fmt_longident_loc od.popen_lid; + (module_expr i) od.popen_expr; attributes i ppf od.popen_attributes | Pstr_class (l) -> line i ppf "Pstr_class\n"; diff --git a/testsuite/tests/parsing/shortcut_ext_attr.ml.reference b/testsuite/tests/parsing/shortcut_ext_attr.ml.reference index c31013494a95..50acd0afbdfa 100644 --- a/testsuite/tests/parsing/shortcut_ext_attr.ml.reference +++ b/testsuite/tests/parsing/shortcut_ext_attr.ml.reference @@ -756,7 +756,10 @@ Pstr_extension "foo" [ structure_item (shortcut_ext_attr.ml[88,1754+0]..[88,1754+16]) - Pstr_open Fresh "M" (shortcut_ext_attr.ml[88,1754+15]..[88,1754+16]) + Pstr_open Fresh + module_expr (shortcut_ext_attr.ml[88,1754+15]..[88,1754+16]) + Pmod_ident "M" (shortcut_ext_attr.ml[88,1754+15]..[88,1754+16]) + attribute "foo" [] ] @@ -929,7 +932,10 @@ Psig_extension "foo" [ signature_item (shortcut_ext_attr.ml[109,2116+2]..[109,2116+18]) - Psig_open Fresh "M" (shortcut_ext_attr.ml[109,2116+17]..[109,2116+18]) + Psig_open Fresh + module_expr (shortcut_ext_attr.ml[109,2116+17]..[109,2116+18]) + Pmod_ident "M" (shortcut_ext_attr.ml[109,2116+17]..[109,2116+18]) + attribute "foo" [] ] diff --git a/testsuite/tests/typing-modules/open-struct.ml b/testsuite/tests/typing-modules/open-struct.ml new file mode 100644 index 000000000000..43970d05ad49 --- /dev/null +++ b/testsuite/tests/typing-modules/open-struct.ml @@ -0,0 +1,101 @@ +type t = A + +module M = struct + open struct type t' = t end + type t = B of t * t' | C +end + +(* test *) +include struct + open M + let test = B (B (C, A), A) +end +[%%expect{| +type t = A +module M : sig type t = B of t * t | C end +val test : M.t = M.B (M.B (M.C, A), A) +|}];; + +include struct + open struct let aux x y = x / y end + let f x = aux x 2 + let g y = aux 3 y +end +[%%expect{| +val f : int -> int = +val g : int -> int = +|}];; + +include struct + open struct exception Interrupt end + let run () = + raise Interrupt + let () = + match run() with exception Interrupt -> () | _ -> assert false +end +[%%expect{| +val run : unit -> 'a = +|}];; + +module type S = sig + open struct + open struct + type t' = char + end + type t = t' -> int end + val x : t +end + +module M : S = struct + let x = Char.code +end +[%%expect{| +module type S = sig val x : char -> int end +module M : S +|}];; + +open struct + open struct let counter = ref 0 end + let inc () = incr counter + let dec () = decr counter + let current () = !counter +end + +let () = + inc(); inc(); dec (); + assert (current () = 1) +[%%expect{| +|}];; + +include struct open struct type t = T end let x = T end +[%%expect{| +Line _, characters 15-41: +Error: The module identifier M#7 cannot be eliminated from val x : M#7.t +|}];; + +module type S = sig open struct assert false end end;; +[%%expect{| +module type S = sig end +|}];; + +module type S = sig open struct type t = int end val x : t end;; +[%%expect{| +module type S = sig val x : int end +|}];; + +module type S = sig + open struct type t = int end + type s = t +end +[%%expect{| +module type S = sig type s = int end +|}] + +module type T = sig type s = int end +module F(X:S) : T = X +module G(X:T) : S = X +[%%expect{| +module type T = sig type s = int end +module F : functor (X : S) -> T +module G : functor (X : T) -> S +|}] diff --git a/typing/printtyped.ml b/typing/printtyped.ml index 78e1b60a5b6e..7e9686ae6c52 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -224,8 +224,8 @@ and pattern i ppf x = line i ppf "Tpat_type %a\n" fmt_path id; attributes i ppf attrs; pattern i ppf { x with pat_extra = rem } - | (Tpat_open (id,_,_), _, attrs)::rem -> - line i ppf "Tpat_open \"%a\"\n" fmt_path id; + | (Tpat_open (id,_), _, attrs)::rem -> + line i ppf "Tpat_open \"%a\"\n" fmt_longident id; attributes i ppf attrs; pattern i ppf { x with pat_extra = rem } | [] -> @@ -270,8 +270,8 @@ and expression_extra i ppf x attrs = attributes i ppf attrs; option i core_type ppf cto1; core_type i ppf cto2; - | Texp_open (ovf, m, _, _) -> - line i ppf "Texp_open %a \"%a\"\n" fmt_override_flag ovf fmt_path m; + | Texp_open (ovf, lid, _) -> + line i ppf "Texp_open %a \"%a\"\n" fmt_override_flag ovf fmt_longident lid; attributes i ppf attrs; | Texp_poly cto -> line i ppf "Texp_poly\n"; @@ -662,9 +662,8 @@ and signature_item i ppf x = attributes i ppf x.mtd_attributes; modtype_declaration i ppf x.mtd_type | Tsig_open od -> - line i ppf "Tsig_open %a %a\n" - fmt_override_flag od.open_override - fmt_path od.open_path; + line i ppf "Tsig_open %a\n" + fmt_override_flag od.open_override; attributes i ppf od.open_attributes | Tsig_include incl -> line i ppf "Tsig_include\n"; @@ -767,9 +766,8 @@ and structure_item i ppf x = attributes i ppf x.mtd_attributes; modtype_declaration i ppf x.mtd_type | Tstr_open od -> - line i ppf "Tstr_open %a %a\n" - fmt_override_flag od.open_override - fmt_path od.open_path; + line i ppf "Tstr_open %a\n" + fmt_override_flag od.open_override; attributes i ppf od.open_attributes | Tstr_class (l) -> line i ppf "Tstr_class\n"; diff --git a/typing/tast_mapper.ml b/typing/tast_mapper.ml index 0873dd4c9ee4..a44ac52e1b64 100644 --- a/typing/tast_mapper.ml +++ b/typing/tast_mapper.ml @@ -124,7 +124,8 @@ let structure_item sub {str_desc; str_loc; str_env} = (List.map (tuple3 id id (sub.class_type_declaration sub)) list) | Tstr_include incl -> Tstr_include (include_infos (sub.module_expr sub) incl) - | Tstr_open _ + | Tstr_open od -> + Tstr_open {od with open_expr = sub.module_expr sub od.open_expr} | Tstr_attribute _ as d -> d in {str_desc; str_env; str_loc} @@ -186,7 +187,7 @@ let pat sub x = let extra = function | Tpat_type _ | Tpat_unpack as d -> d - | Tpat_open (path,loc,env) -> Tpat_open (path, loc, sub.env sub env) + | Tpat_open (loc,env) -> Tpat_open (loc, sub.env sub env) | Tpat_constraint ct -> Tpat_constraint (sub.typ sub ct) in let pat_env = sub.env sub x.pat_env in @@ -216,8 +217,8 @@ let expr sub x = Texp_constraint (sub.typ sub cty) | Texp_coerce (cty1, cty2) -> Texp_coerce (opt (sub.typ sub) cty1, sub.typ sub cty2) - | Texp_open (ovf, path, loc, env) -> - Texp_open (ovf, path, loc, sub.env sub env) + | Texp_open (ovf, loc, env) -> + Texp_open (ovf, loc, sub.env sub env) | Texp_newtype _ as d -> d | Texp_poly cto -> Texp_poly (opt (sub.typ sub) cto) in @@ -387,7 +388,8 @@ let signature_item sub x = | Tsig_class_type list -> Tsig_class_type (List.map (sub.class_type_declaration sub) list) - | Tsig_open _ + | Tsig_open od -> + Tsig_open {od with open_expr = sub.module_expr sub od.open_expr} | Tsig_attribute _ as d -> d in {x with sig_desc; sig_env} diff --git a/typing/typecore.ml b/typing/typecore.ml index a06b8c283d35..26806018104e 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -1366,12 +1366,13 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env k { p with pat_extra = (Tpat_type (path, lid), loc, sp.ppat_attributes) :: p.pat_extra } | Ppat_open (lid,p) -> - let path, new_env = - !type_open Asttypes.Fresh !env sp.ppat_loc lid in + let me = {pmod_desc=Pmod_ident lid; pmod_loc=lid.loc; pmod_attributes=[]} in + let _tme, new_env = + !type_open Asttypes.Fresh !env sp.ppat_loc me in let new_env = ref new_env in type_pat ~env:new_env p expected_ty ( fun p -> env := Env.copy_local !env ~from:!new_env; - k { p with pat_extra =( Tpat_open (path,lid,!new_env), + k { p with pat_extra =( Tpat_open (lid,!new_env), loc, sp.ppat_attributes) :: p.pat_extra } ) | Ppat_exception _ -> @@ -1853,7 +1854,9 @@ let contains_gadt env p = with Not_found -> () end; iter_ppat (loop env) p | Ppat_open (lid,sub_p) -> - let _, new_env = !type_open Asttypes.Override env p.ppat_loc lid in + let me = {pmod_desc=Pmod_ident lid; pmod_loc=lid.loc; + pmod_attributes=[]} in + let _, new_env = !type_open Asttypes.Override env p.ppat_loc me in loop new_env sub_p | _ -> iter_ppat (loop env) p in @@ -2966,10 +2969,12 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = exp_attributes = sexp.pexp_attributes; exp_env = env } | Pexp_open (ovf, lid, e) -> - let (path, newenv) = !type_open ovf env sexp.pexp_loc lid in + let me = {pmod_desc=Pmod_ident lid; pmod_loc=lid.loc; + pmod_attributes=[]} in + let (_tme, newenv) = !type_open ovf env sexp.pexp_loc me in let exp = type_expect newenv e ty_expected in { exp with - exp_extra = (Texp_open (ovf, path, lid, newenv), loc, + exp_extra = (Texp_open (ovf, lid, newenv), loc, sexp.pexp_attributes) :: exp.exp_extra; } diff --git a/typing/typecore.mli b/typing/typecore.mli index 7b64ee343cb5..65c3c10d34ce 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -135,7 +135,7 @@ val report_error: Env.t -> formatter -> error -> unit val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref (* Forward declaration, to be filled in by Typemod.type_open *) val type_open: - (override_flag -> Env.t -> Location.t -> Longident.t loc -> Path.t * Env.t) + (override_flag -> Env.t -> Location.t -> Parsetree.module_expr -> Typedtree.module_expr * Env.t) ref (* Forward declaration, to be filled in by Typeclass.class_structure *) val type_object: diff --git a/typing/typedtree.ml b/typing/typedtree.ml index db4440c18f78..063a9eb56862 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -38,7 +38,7 @@ type pattern = and pat_extra = | Tpat_constraint of core_type | Tpat_type of Path.t * Longident.t loc - | Tpat_open of Path.t * Longident.t loc * Env.t + | Tpat_open of Longident.t loc * Env.t | Tpat_unpack and pattern_desc = @@ -69,7 +69,7 @@ and expression = and exp_extra = | Texp_constraint of core_type | Texp_coerce of core_type option * core_type - | Texp_open of override_flag * Path.t * Longident.t loc * Env.t + | Texp_open of override_flag * Longident.t loc * Env.t | Texp_poly of core_type option | Texp_newtype of string @@ -330,8 +330,7 @@ and module_type_declaration = and open_description = { - open_path: Path.t; - open_txt: Longident.t loc; + open_expr: module_expr; open_override: override_flag; open_loc: Location.t; open_attributes: attribute list; diff --git a/typing/typedtree.mli b/typing/typedtree.mli index ee26bca3e17b..f3e4107338bc 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -56,7 +56,7 @@ and pat_extra = where [disjunction] is a [Tpat_or _] representing the branches of [tconst]. *) - | Tpat_open of Path.t * Longident.t loc * Env.t + | Tpat_open of Longident.t loc * Env.t | Tpat_unpack (** (module P) { pat_desc = Tpat_var "P" ; pat_extra = (Tpat_unpack, _, _) :: ... } @@ -123,7 +123,7 @@ and exp_extra = (** E :> T [Texp_coerce (None, T)] E : T0 :> T [Texp_coerce (Some T0, T)] *) - | Texp_open of override_flag * Path.t * Longident.t loc * Env.t + | Texp_open of override_flag * Longident.t loc * Env.t (** let open[!] M in [Texp_open (!, P, M, env)] where [env] is the environment after opening [P] *) @@ -450,8 +450,7 @@ and module_type_declaration = and open_description = { - open_path: Path.t; - open_txt: Longident.t loc; + open_expr: module_expr; open_override: override_flag; open_loc: Location.t; open_attributes: attribute list; diff --git a/typing/typemod.ml b/typing/typemod.ml index 77de1f29261b..9b69bca03089 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -43,6 +43,8 @@ type error = | Recursive_module_require_explicit_type | Apply_generative | Cannot_scrape_alias of Path.t + | Invalid_open of Parsetree.module_expr + | Cannot_eliminate_anon_module of Ident.t * signature exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -82,29 +84,126 @@ let extract_sig_open env loc mty = (* Compute the environment after opening a module *) -let type_open_ ?toplevel ovf env loc lid = - let path = Typetexp.lookup_module ~load:true env lid.loc lid.txt in - match Env.open_signature ~loc ?toplevel ovf path env with - | Some env -> path, env - | None -> - let md = Env.find_module path env in - ignore (extract_sig_open env lid.loc md.md_type); - assert false - -let type_open ?toplevel env sod = - let (path, newenv) = - type_open_ ?toplevel sod.popen_override env sod.popen_loc sod.popen_lid +let type_module_fwd : (Env.t -> Parsetree.module_expr -> + Typedtree.module_expr) ref = + ref (fun _ _ -> assert false) + +let mod_ident_counter = ref 0 +let generated_module_ident = ref [] +let generated_module_ident_in_sig = ref [] + +let push_current_mid (mi, md, env) in_sig = + if in_sig then + generated_module_ident_in_sig := (mi, md, env) :: !generated_module_ident + else + generated_module_ident := (mi, md, env) :: !generated_module_ident + +let pop_current_mid in_sig = + let slots = + if in_sig then generated_module_ident_in_sig + else generated_module_ident in + let slot = List.hd !slots in + slots := List.tl !slots; + slot + +let gen_mod_ident () = + let n = !mod_ident_counter in + incr mod_ident_counter; + let ident = Ident.create (Printf.sprintf "M#%d" n) in + ident + +let saved_full_mod_types = ref [] +let push_mod_type mt = + saved_full_mod_types := mt :: !saved_full_mod_types +let pop_mod_type () = + let mt = List.hd !saved_full_mod_types in + saved_full_mod_types := List.tl !saved_full_mod_types; + mt + +let open_struct_level = ref 0 +let enter_struct () = incr open_struct_level +let leave_struct () = decr open_struct_level + +let type_open_ ?toplevel in_sig ovf env loc me = + match me.pmod_desc with + | Pmod_functor _ | Pmod_unpack _ | Pmod_extension _ -> + raise(Error(me.pmod_loc, env, Invalid_open me)) + | Pmod_ident lid -> begin + let path = Typetexp.lookup_module ~load:true env lid.loc lid.txt in + match Env.open_signature ~loc ?toplevel ovf path env with + | Some env -> + let tme = + { + mod_desc=Tmod_ident (path, lid); + mod_loc=lid.loc; + mod_type=Mty_ident path; + mod_env=env; + mod_attributes=me.pmod_attributes + } in + tme, env + | None -> + let md = Env.find_module path env in + ignore (extract_sig_open env lid.loc md.md_type); + assert false + end + | _ -> begin + enter_struct (); + let ident = gen_mod_ident () in + let tme = !type_module_fwd env me in + leave_struct (); + begin + match tme.mod_type with + | Mty_signature _ -> () + | _ -> raise(Error(me.pmod_loc, env, Invalid_open me)); + end; + let full_modtype = pop_mod_type () in + let md = { + md_type = full_modtype; + md_loc = me.pmod_loc; + md_attributes = me.pmod_attributes; + } in + let newenv = Env.enter_module_declaration ident md env in + push_current_mid (ident, md, newenv) in_sig; + let root = Pident ident in + match Env.open_signature ~loc ?toplevel ovf root newenv with + | None -> assert false + | Some opened_env -> tme, opened_env + end + +let extract_open od in_sig = + match od.open_expr.mod_desc with + | Tmod_ident (_, _) -> None + | Tmod_structure _ | Tmod_apply _ | Tmod_constraint _ -> + let id, md, env = + if in_sig then List.hd !generated_module_ident_in_sig + else (pop_current_mid false) in + let tm = + Tstr_module {mb_id=id; + mb_name={txt=Ident.name id; loc=Location.none}; + mb_expr = od.open_expr; + mb_attributes=od.open_expr.mod_attributes; + mb_loc=od.open_expr.mod_loc} in + Some (tm, md, id, env) + | _ -> assert false + +let extract_open_struct = function + | Tstr_open od -> extract_open od false + | _ -> None + +let type_open ?toplevel env sod in_sig = + let (tme, newenv) = + type_open_ ?toplevel in_sig sod.popen_override env sod.popen_loc + sod.popen_expr in let od = { open_override = sod.popen_override; - open_path = path; - open_txt = sod.popen_lid; + open_expr = tme; open_attributes = sod.popen_attributes; open_loc = sod.popen_loc; } in - (path, newenv, od) + newenv, od (* Record a module type *) let rm node = @@ -397,7 +496,7 @@ and approx_sig env ssg = let (id, newenv) = Env.enter_modtype d.pmtd_name.txt info env in Sig_modtype(id, info) :: approx_sig newenv srem | Psig_open sod -> - let (_path, mty, _od) = type_open env sod in + let (mty, _od) = type_open env sod true in approx_sig mty srem | Psig_include sincl -> let smty = sincl.pincl_mod in @@ -672,11 +771,30 @@ and transl_signature env sg = mksig (Tsig_modtype mtd) env loc :: trem, sg :: rem, final_env - | Psig_open sod -> - let (_path, newenv, od) = type_open env sod in + | Psig_open sod -> begin + let (newenv, od) = type_open env sod true in let (trem, rem, final_env) = transl_sig newenv srem in + let remr = ref rem in + begin + if !open_struct_level = 0 then + begin + match extract_open od true with + | None -> () + | Some (_, _, id, _) -> begin + let s_rem = Mty_signature rem in begin + match Mtype.nondep_supertype newenv id s_rem with + | Mty_signature rem' -> remr := rem' + | exception Not_found -> + raise(Error(sod.popen_loc, env, + Cannot_eliminate_anon_module(id, rem))) + | _ -> assert false + end + end + end else () + end; mksig (Tsig_open od) env loc :: trem, - rem, final_env + !remr, final_env + end | Psig_include sincl -> let smty = sincl.pincl_mod in let tmty = @@ -1380,7 +1498,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = in Tstr_modtype mtd, [sg], newenv | Pstr_open sod -> - let (_path, newenv, od) = type_open ~toplevel env sod in + let (newenv, od) = type_open ~toplevel env sod false in Tstr_open od, [], newenv | Pstr_class cl -> List.iter @@ -1461,22 +1579,51 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = let rec type_struct env sstr = Ctype.init_def(Ident.current_time()); match sstr with - | [] -> ([], [], env) - | pstr :: srem -> + | [] -> ([], [], [], env) + | pstr :: srem -> begin let previous_saved_types = Cmt_format.get_saved_types () in let desc, sg, new_env = type_str_item env srem pstr in let str = { str_desc = desc; str_loc = pstr.pstr_loc; str_env = env } in Cmt_format.set_saved_types (Cmt_format.Partial_structure_item str :: previous_saved_types); - let (str_rem, sig_rem, final_env) = type_struct new_env srem in - (str :: str_rem, sg @ sig_rem, final_env) + let (str_rem, sig_rem, fsig_rem, final_env) = type_struct new_env srem in + match extract_open_struct desc with + | Some (tm, md, id, md_env) -> begin + let loc = pstr.pstr_loc in + let tm_str = {str_desc = tm; str_loc = loc; + str_env = env} in + let open_str = {str with str_env = md_env} in + let md_sig = + Sig_module (id, {md_type=md.Types.md_type; md_loc=loc; + md_attributes = []}, Trec_not) in + if !open_struct_level = 0 then begin + let s_rem = Mty_signature sig_rem in begin + match Mtype.nondep_supertype new_env id s_rem with + | Mty_signature sg -> + (tm_str :: open_str :: str_rem, sg, + md_sig :: fsig_rem, final_env) + | exception Not_found -> + raise(Error(pstr.pstr_loc, env, + Cannot_eliminate_anon_module(id, sig_rem))) + | _ -> assert false + end + end else + (tm_str :: open_str :: str_rem, sig_rem, + md_sig :: fsig_rem, final_env) + end + | None -> + (str :: str_rem, sg @ sig_rem, sg @ fsig_rem, final_env) + end in if !Clflags.annotations then (* moved to genannot *) List.iter (function {pstr_loc = l} -> Stypes.record_phrase l) sstr; let previous_saved_types = Cmt_format.get_saved_types () in if not toplevel then Builtin_attributes.warning_enter_scope (); - let (items, sg, final_env) = type_struct env sstr in + let (items, sg, full_sg, final_env) = type_struct env sstr in + if !open_struct_level <> 0 then begin + push_mod_type (Mty_signature full_sg) + end; let str = { str_items = items; str_type = sg; str_final_env = final_env } in if not toplevel then Builtin_attributes.warning_leave_scope (); Cmt_format.set_saved_types @@ -1584,8 +1731,9 @@ let () = Typecore.type_module := type_module_alias; Typetexp.transl_modtype_longident := transl_modtype_longident; Typetexp.transl_modtype := transl_modtype; - Typecore.type_open := type_open_ ?toplevel:None; + Typecore.type_open := type_open_ ?toplevel:None false; Typecore.type_package := type_package; + type_module_fwd := type_module; type_module_type_of_fwd := type_module_type_of @@ -1825,6 +1973,11 @@ let report_error ppf = function fprintf ppf "This is an alias for module %a, which is missing" path p + | Invalid_open _me -> + fprintf ppf "Invalid open" + | Cannot_eliminate_anon_module (id, sg) -> + fprintf ppf "The module identifier %a cannot be \ + eliminated from %a" ident id signature sg let report_error env ppf err = Printtyp.wrap_printing_env env (fun () -> report_error ppf err) diff --git a/typing/typemod.mli b/typing/typemod.mli index fab7cdae5317..e421c141bd97 100644 --- a/typing/typemod.mli +++ b/typing/typemod.mli @@ -36,8 +36,9 @@ val transl_signature: val check_nongen_schemes: Env.t -> Types.signature -> unit val type_open_: - ?toplevel:bool -> Asttypes.override_flag -> - Env.t -> Location.t -> Longident.t Asttypes.loc -> Path.t * Env.t + ?toplevel:bool -> bool -> Asttypes.override_flag -> + Env.t -> Location.t -> Parsetree.module_expr -> + Typedtree.module_expr * Env.t val modtype_of_package: Env.t -> Location.t -> Path.t -> Longident.t list -> type_expr list -> module_type @@ -74,6 +75,8 @@ type error = | Recursive_module_require_explicit_type | Apply_generative | Cannot_scrape_alias of Path.t + | Invalid_open of Parsetree.module_expr + | Cannot_eliminate_anon_module of Ident.t * signature exception Error of Location.t * Env.t * error exception Error_forward of Location.error diff --git a/typing/untypeast.ml b/typing/untypeast.ml index 0cb58f484a68..10649dcf661d 100644 --- a/typing/untypeast.ml +++ b/typing/untypeast.ml @@ -135,7 +135,7 @@ let open_description sub od = let attrs = sub.attributes sub od.open_attributes in Opn.mk ~loc ~attrs ~override:od.open_override - (map_loc sub od.open_txt) + (sub.module_expr sub od.open_expr) let structure_item sub item = let loc = sub.location sub item.str_loc in @@ -328,7 +328,7 @@ let exp_extra sub (extra, loc, attrs) sexp = sub.typ sub cty2) | Texp_constraint cty -> Pexp_constraint (sexp, sub.typ sub cty) - | Texp_open (ovf, _path, lid, _) -> + | Texp_open (ovf, lid, _) -> Pexp_open (ovf, map_loc sub lid, sexp) | Texp_poly cto -> Pexp_poly (sexp, map_opt (sub.typ sub) cto) | Texp_newtype s -> Pexp_newtype (mkloc s loc, sexp) From 52b97803c56b2edddbc037f7137741de6b5fb221 Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Mon, 20 Nov 2017 16:39:03 -0800 Subject: [PATCH 02/39] Fix problem after merge. --- bytecomp/translclass.ml | 8 ++-- testsuite/tests/parsetree/source.ml | 66 +++++++++++++++++++++++++++++ typing/printtyped.ml | 10 +++-- typing/tast_mapper.ml | 8 ++-- typing/typeclass.ml | 15 ++++--- typing/typecore.ml | 6 +-- typing/typedtree.ml | 4 +- typing/typedtree.mli | 4 +- typing/typedtreeIter.ml | 4 +- typing/typedtreeMap.ml | 8 ++-- typing/typemod.ml | 8 +++- typing/typemod.mli | 7 ++- typing/untypeast.ml | 4 +- 13 files changed, 113 insertions(+), 39 deletions(-) diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index d5ffd339197d..92fac3ef2ea4 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -195,7 +195,7 @@ let rec build_object_init cl_table obj params inh_init obj_init cl = build_object_init cl_table obj (vals @ params) inh_init obj_init cl in (inh_init, Translcore.transl_let rec_flag defs obj_init) - | Tcl_open (_, _, _, _, cl) + | Tcl_open (_, _, _, cl) | Tcl_constraint (cl, _, _, _, _) -> build_object_init cl_table obj params inh_init obj_init cl @@ -387,7 +387,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = Lsequence(mkappl (oo_prim "narrow", narrow_args), cl_init)) end - | Tcl_open (_, _, _, _, cl) -> + | Tcl_open (_, _, _, cl) -> build_class_init cla cstr super inh_init cl_init msubst top cl let rec build_class_lets cl = @@ -407,7 +407,7 @@ let rec get_class_meths cl = | Tcl_fun (_, _, _, cl, _) | Tcl_let (_, _, _, cl) | Tcl_apply (cl, _) - | Tcl_open (_, _, _, _, cl) + | Tcl_open (_, _, _, cl) | Tcl_constraint (cl, _, _, _, _) -> get_class_meths cl (* @@ -453,7 +453,7 @@ let rec transl_class_rebind obj_init cl vf = in check_constraint cl.cl_type; (path, obj_init) - | Tcl_open (_, _, _, _, cl) -> + | Tcl_open (_, _, _, cl) -> transl_class_rebind obj_init cl vf let rec transl_class_rebind_0 self obj_init cl vf = diff --git a/testsuite/tests/parsetree/source.ml b/testsuite/tests/parsetree/source.ml index 28fb4a40419d..cd1f996012ca 100644 --- a/testsuite/tests/parsetree/source.ml +++ b/testsuite/tests/parsetree/source.ml @@ -7340,3 +7340,69 @@ module Indexop = struct h.Def.%{"three"} <- 3 let x,y,z = Def.(h.%["one"], h.%("two"), h.%{"three"}) end + +type t = A + +module M = struct + open struct type t' = t end + type t = B of t * t' | C +end + +(* test *) +include struct + open M + let test = B (B (C, A), A) +end + +include struct + open struct let aux x y = x / y end + let f x = aux x 2 + let g y = aux 3 y +end + +include struct + open struct exception Interrupt end + let run () = + raise Interrupt + let () = + match run() with exception Interrupt -> () | _ -> assert false +end + +module type S = sig + open struct + open struct + type t' = char + end + type t = t' -> int end + val x : t +end + +module M : S = struct + let x = Char.code +end + +open struct + open struct let counter = ref 0 end + let inc () = incr counter + let dec () = decr counter + let current () = !counter +end + +let () = + inc(); inc(); dec (); + assert (current () = 1) + +include struct open struct type t = T end let x = T end + +module type S = sig open struct assert false end end;; + +module type S = sig open struct type t = int end val x : t end;; + +module type S = sig + open struct type t = int end + type s = t +end + +module type T = sig type s = int end +module F(X:S) : T = X +module G(X:T) : S = X diff --git a/typing/printtyped.ml b/typing/printtyped.ml index 54dc865ce4fd..402da194c2f8 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -493,8 +493,9 @@ and class_type i ppf x = arg_label i ppf l; core_type i ppf co; class_type i ppf cl; - | Tcty_open (ovf, m, _, _, e) -> - line i ppf "Tcty_open %a \"%a\"\n" fmt_override_flag ovf fmt_path m; + | Tcty_open (ovf, id, _, e) -> + line i ppf "Tcty_open %a \"%a\"\n" fmt_override_flag ovf + fmt_longident id; class_type i ppf e and class_signature i ppf { csig_self = ct; csig_fields = l } = @@ -577,8 +578,9 @@ and class_expr i ppf x = class_expr i ppf ce; class_type i ppf ct | Tcl_constraint (ce, None, _, _, _) -> class_expr i ppf ce - | Tcl_open (ovf, m, _, _, e) -> - line i ppf "Tcty_open %a \"%a\"\n" fmt_override_flag ovf fmt_path m; + | Tcl_open (ovf, id, _, e) -> + line i ppf "Tcty_open %a \"%a\"\n" fmt_override_flag ovf + fmt_longident id; class_expr i ppf e and class_structure i ppf { cstr_self = p; cstr_fields = l } = diff --git a/typing/tast_mapper.ml b/typing/tast_mapper.ml index 3ec5bdf63a23..9175758c2ca9 100644 --- a/typing/tast_mapper.ml +++ b/typing/tast_mapper.ml @@ -524,8 +524,8 @@ let class_expr sub x = ) | Tcl_ident (path, lid, tyl) -> Tcl_ident (path, lid, List.map (sub.typ sub) tyl) - | Tcl_open (ovf, p, lid, env, e) -> - Tcl_open (ovf, p, lid, sub.env sub env, sub.class_expr sub e) + | Tcl_open (ovf, lid, env, e) -> + Tcl_open (ovf, lid, sub.env sub env, sub.class_expr sub e) in {x with cl_desc; cl_env} @@ -546,8 +546,8 @@ let class_type sub x = sub.typ sub ct, sub.class_type sub cl ) - | Tcty_open (ovf, p, lid, env, e) -> - Tcty_open (ovf, p, lid, sub.env sub env, sub.class_type sub e) + | Tcty_open (ovf, lid, env, e) -> + Tcty_open (ovf, lid, sub.env sub env, sub.class_type sub e) in {x with cltyp_desc; cltyp_env} diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 0d658878aa71..f3919fa6da98 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -554,9 +554,11 @@ and class_type_aux env scty = cltyp (Tcty_arrow (l, cty, clty)) typ | Pcty_open (ovf, lid, e) -> - let (path, newenv) = !Typecore.type_open ovf env scty.pcty_loc lid in + let me = {pmod_desc=Pmod_ident lid; pmod_loc=lid.loc; + pmod_attributes=[]} in + let (_tme, newenv) = !Typecore.type_open ovf env scty.pcty_loc me in let clty = class_type newenv e in - cltyp (Tcty_open (ovf, path, lid, newenv, clty)) clty.cltyp_type + cltyp (Tcty_open (ovf, lid, newenv, clty)) clty.cltyp_type | Pcty_extension ext -> raise (Error_forward (Builtin_attributes.error_of_extension ext)) @@ -1224,10 +1226,11 @@ and class_expr_aux cl_num val_env met_env scl = } | Pcl_open (ovf, lid, e) -> let used_slot = ref false in - let (path, new_val_env) = !Typecore.type_open ~used_slot ovf val_env scl.pcl_loc lid in - let (_path, new_met_env) = !Typecore.type_open ~used_slot ovf met_env scl.pcl_loc lid in + let me = {pmod_desc=Pmod_ident lid; pmod_loc=lid.loc; pmod_attributes=[]} in + let (_, new_val_env) = !Typecore.type_open ~used_slot ovf val_env scl.pcl_loc me in + let (_, new_met_env) = !Typecore.type_open ~used_slot ovf met_env scl.pcl_loc me in let cl = class_expr cl_num new_val_env new_met_env e in - rc {cl_desc = Tcl_open (ovf, path, lid, new_val_env, cl); + rc {cl_desc = Tcl_open (ovf, lid, new_val_env, cl); cl_loc = scl.pcl_loc; cl_type = cl.cl_type; cl_env = val_env; @@ -1772,7 +1775,7 @@ let rec unify_parents env ty cl = | _exn -> assert false end | Tcl_structure st -> unify_parents_struct env ty st - | Tcl_open (_, _, _, _, cl) + | Tcl_open (_, _, _, cl) | Tcl_fun (_, _, _, cl, _) | Tcl_apply (cl, _) | Tcl_let (_, _, _, cl) diff --git a/typing/typecore.ml b/typing/typecore.ml index 483a04156614..4f07003d7019 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -95,7 +95,7 @@ let type_module = let type_open : (?used_slot:bool ref -> override_flag -> Env.t -> Location.t -> - Longident.t loc -> Path.t * Env.t) + Parsetree.module_expr -> Typedtree.module_expr * Env.t) ref = ref (fun ?used_slot:_ _ -> assert false) @@ -2221,7 +2221,7 @@ struct Use.(inspect (join ty (class_expr env ce))) | Tcl_constraint (ce, _, _, _, _) -> class_expr env ce - | Tcl_open (_, _, _, _, ce) -> + | Tcl_open (_, _, _, ce) -> class_expr env ce and case : Env.env -> Typedtree.case -> scrutinee:Use.t -> Use.t = fun env { Typedtree.c_lhs; c_guard; c_rhs } ~scrutinee:ty -> @@ -2321,7 +2321,7 @@ struct Use.join ty (class_expr env ce) | Tcl_constraint (ce, _, _, _, _) -> class_expr env ce - | Tcl_open (_, _, _, _, ce) -> + | Tcl_open (_, _, _, ce) -> class_expr env ce in match Use.unguarded (class_expr (build_unguarded_env idlist) ce) with diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 11f540ead73c..541bea93f648 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -153,7 +153,7 @@ and class_expr_desc = | Tcl_constraint of class_expr * class_type option * string list * string list * Concr.t (* Visible instance variables, methods and concrete methods *) - | Tcl_open of override_flag * Path.t * Longident.t loc * Env.t * class_expr + | Tcl_open of override_flag * Longident.t loc * Env.t * class_expr and class_structure = { @@ -482,7 +482,7 @@ and class_type_desc = Tcty_constr of Path.t * Longident.t loc * core_type list | Tcty_signature of class_signature | Tcty_arrow of arg_label * core_type * class_type - | Tcty_open of override_flag * Path.t * Longident.t loc * Env.t * class_type + | Tcty_open of override_flag * Longident.t loc * Env.t * class_type and class_signature = { csig_self: core_type; diff --git a/typing/typedtree.mli b/typing/typedtree.mli index 6c47db4fbca4..58df8efa019f 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -268,7 +268,7 @@ and class_expr_desc = | Tcl_constraint of class_expr * class_type option * string list * string list * Concr.t (* Visible instance variables, methods and concrete methods *) - | Tcl_open of override_flag * Path.t * Longident.t loc * Env.t * class_expr + | Tcl_open of override_flag * Longident.t loc * Env.t * class_expr and class_structure = { @@ -604,7 +604,7 @@ and class_type_desc = Tcty_constr of Path.t * Longident.t loc * core_type list | Tcty_signature of class_signature | Tcty_arrow of arg_label * core_type * class_type - | Tcty_open of override_flag * Path.t * Longident.t loc * Env.t * class_type + | Tcty_open of override_flag * Longident.t loc * Env.t * class_type and class_signature = { csig_self : core_type; diff --git a/typing/typedtreeIter.ml b/typing/typedtreeIter.ml index a3be8d3be547..be5b071c9522 100644 --- a/typing/typedtreeIter.ml +++ b/typing/typedtreeIter.ml @@ -512,7 +512,7 @@ module MakeIterator(Iter : IteratorArgument) : sig | Tcl_ident (_, _, tyl) -> List.iter iter_core_type tyl - | Tcl_open (_, _, _, _, e) -> + | Tcl_open (_, _, _, e) -> iter_class_expr e end; Iter.leave_class_expr cexpr; @@ -527,7 +527,7 @@ module MakeIterator(Iter : IteratorArgument) : sig | Tcty_arrow (_label, ct, cl) -> iter_core_type ct; iter_class_type cl - | Tcty_open (_, _, _, _, e) -> + | Tcty_open (_, _, _, e) -> iter_class_type e end; Iter.leave_class_type ct; diff --git a/typing/typedtreeMap.ml b/typing/typedtreeMap.ml index ccde8c03a4b5..f671f39d9d81 100644 --- a/typing/typedtreeMap.ml +++ b/typing/typedtreeMap.ml @@ -567,8 +567,8 @@ module MakeMap(Map : MapArgument) = struct | Tcl_ident (id, name, tyl) -> Tcl_ident (id, name, List.map map_core_type tyl) - | Tcl_open (ovf, p, lid, env, e) -> - Tcl_open (ovf, p, lid, env, map_class_expr e) + | Tcl_open (ovf, lid, env, e) -> + Tcl_open (ovf, lid, env, map_class_expr e) in Map.leave_class_expr { cexpr with cl_desc = cl_desc } @@ -581,8 +581,8 @@ module MakeMap(Map : MapArgument) = struct Tcty_constr (path, lid, List.map map_core_type list) | Tcty_arrow (label, ct, cl) -> Tcty_arrow (label, map_core_type ct, map_class_type cl) - | Tcty_open (ovf, p, lid, env, e) -> - Tcty_open (ovf, p, lid, env, map_class_type e) + | Tcty_open (ovf, lid, env, e) -> + Tcty_open (ovf, lid, env, map_class_type e) in Map.leave_class_type { ct with cltyp_desc = cltyp_desc } diff --git a/typing/typemod.ml b/typing/typemod.ml index 37ec2a47086a..a64be4b6cc26 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -1805,7 +1805,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = List.iter (function {pstr_loc = l} -> Stypes.record_phrase l) sstr; let previous_saved_types = Cmt_format.get_saved_types () in let run () = - let (items, sg, final_env) = type_struct env sstr in + let (items, sg, full_sg, final_env) = type_struct env sstr in if !open_struct_level <> 0 then begin push_mod_type (Mty_signature full_sg) end; @@ -1912,11 +1912,15 @@ let type_package env m p nl = (wrap_constraint env modl mty Tmodtype_implicit, tl') (* Fill in the forward declarations *) + +let type_open ?used_slot ovf env loc me = + type_open_ ?used_slot ?toplevel:None false ovf env loc me + let () = Typecore.type_module := type_module_alias; Typetexp.transl_modtype_longident := transl_modtype_longident; Typetexp.transl_modtype := transl_modtype; - Typecore.type_open := type_open_ ?toplevel:None false; + Typecore.type_open := type_open; Typecore.type_package := type_package; type_module_fwd := type_module; type_module_type_of_fwd := type_module_type_of diff --git a/typing/typemod.mli b/typing/typemod.mli index 6c809c81603f..462234ad61e0 100644 --- a/typing/typemod.mli +++ b/typing/typemod.mli @@ -36,10 +36,9 @@ val transl_signature: val check_nongen_schemes: Env.t -> Types.signature -> unit val type_open_: - ?used_slot:bool ref -> ?toplevel:bool -> Asttypes.override_flag -> - Env.t -> Location.t -> Parsetree.module_expr -> - Typedtree.module_expr * Env.t ->>>>>>> trunk + ?used_slot:bool ref -> ?toplevel:bool -> bool -> + Asttypes.override_flag -> Env.t -> Location.t -> + Parsetree.module_expr -> Typedtree.module_expr * Env.t val modtype_of_package: Env.t -> Location.t -> Path.t -> Longident.t list -> type_expr list -> module_type diff --git a/typing/untypeast.ml b/typing/untypeast.ml index b3c080ea8706..e242399941cf 100644 --- a/typing/untypeast.ml +++ b/typing/untypeast.ml @@ -634,7 +634,7 @@ let class_expr sub cexpr = | Tcl_constraint (cl, Some clty, _vals, _meths, _concrs) -> Pcl_constraint (sub.class_expr sub cl, sub.class_type sub clty) - | Tcl_open (ovf, _p, lid, _env, e) -> + | Tcl_open (ovf, lid, _env, e) -> Pcl_open (ovf, lid, sub.class_expr sub e) | Tcl_ident _ -> assert false @@ -651,7 +651,7 @@ let class_type sub ct = Pcty_constr (map_loc sub lid, List.map (sub.typ sub) list) | Tcty_arrow (label, ct, cl) -> Pcty_arrow (label, sub.typ sub ct, sub.class_type sub cl) - | Tcty_open (ovf, _p, lid, _env, e) -> + | Tcty_open (ovf, lid, _env, e) -> Pcty_open (ovf, lid, sub.class_type sub e) in Cty.mk ~loc ~attrs desc From 6822a0538f41da28ac13ff683e81f2eaefdaefdc Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Mon, 20 Nov 2017 18:12:16 -0800 Subject: [PATCH 03/39] remove hack. --- driver/compmisc.ml | 2 +- ocamldoc/odoc_analyse.ml | 2 +- typing/typemod.ml | 54 +++++++++++++++++----------------------- typing/typemod.mli | 2 +- 4 files changed, 26 insertions(+), 34 deletions(-) diff --git a/driver/compmisc.ml b/driver/compmisc.ml index b5970e45d99d..bb162511bf0d 100644 --- a/driver/compmisc.ml +++ b/driver/compmisc.ml @@ -48,7 +48,7 @@ let open_implicit_module m env = let loc = Location.in_file "command line" in let lid = {loc; txt = Longident.parse m } in let me = Parsetree.({pmod_desc=Pmod_ident lid; pmod_loc=loc; pmod_attributes=[]}) in - snd (Typemod.type_open_ ?toplevel:None false Override env lid.loc me) + snd (Typemod.type_open_ ?toplevel:None Override env lid.loc me) let initial_env () = Ident.reinit(); diff --git a/ocamldoc/odoc_analyse.ml b/ocamldoc/odoc_analyse.ml index 5de85d40fdaa..b29921f5b22f 100644 --- a/ocamldoc/odoc_analyse.ml +++ b/ocamldoc/odoc_analyse.ml @@ -44,7 +44,7 @@ let initial_env () = let lid = {loc; txt = Longident.parse m } in let me = Parsetree.({pmod_desc=Pmod_ident lid; pmod_loc=loc; pmod_attributes=[]}) in - snd (Typemod.type_open_ ?toplevel:None false Override env lid.loc me) in + snd (Typemod.type_open_ ?toplevel:None Override env lid.loc me) in (* Open the list of modules given as arguments of the "-open" flag The list is reversed to open the modules in the left-to-right order *) let to_open = List.rev !Clflags.open_modules in diff --git a/typing/typemod.ml b/typing/typemod.ml index a64be4b6cc26..0a1997e9f46c 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -93,20 +93,13 @@ let type_module_fwd : (Env.t -> Parsetree.module_expr -> let mod_ident_counter = ref 0 let generated_module_ident = ref [] -let generated_module_ident_in_sig = ref [] - -let push_current_mid (mi, md, env) in_sig = - if in_sig then - generated_module_ident_in_sig := (mi, md, env) :: !generated_module_ident - else - generated_module_ident := (mi, md, env) :: !generated_module_ident - -let pop_current_mid in_sig = - let slots = - if in_sig then generated_module_ident_in_sig - else generated_module_ident in - let slot = List.hd !slots in - slots := List.tl !slots; + +let push_current_mid (mi, md, env) = + generated_module_ident := (mi, md, env) :: !generated_module_ident + +let pop_current_mid () = + let slot = List.hd !generated_module_ident in + generated_module_ident := List.tl !generated_module_ident; slot let gen_mod_ident () = @@ -124,10 +117,11 @@ let pop_mod_type () = mt let open_struct_level = ref 0 +let in_nested_struct () = !open_struct_level <> 0 let enter_struct () = incr open_struct_level let leave_struct () = decr open_struct_level -let type_open_ ?used_slot ?toplevel in_sig ovf env loc me = +let type_open_ ?used_slot ?toplevel ovf env loc me = match me.pmod_desc with | Pmod_functor _ | Pmod_unpack _ | Pmod_extension _ -> raise(Error(me.pmod_loc, env, Invalid_open me)) @@ -166,20 +160,18 @@ let type_open_ ?used_slot ?toplevel in_sig ovf env loc me = md_attributes = me.pmod_attributes; } in let newenv = Env.enter_module_declaration ident md env in - push_current_mid (ident, md, newenv) in_sig; + push_current_mid (ident, md, newenv); let root = Pident ident in match Env.open_signature ~loc ?used_slot ?toplevel ovf root newenv with | None -> assert false | Some opened_env -> tme, opened_env end -let extract_open od in_sig = +let extract_open od = match od.open_expr.mod_desc with | Tmod_ident (_, _) -> None | Tmod_structure _ | Tmod_apply _ | Tmod_constraint _ -> - let id, md, env = - if in_sig then List.hd !generated_module_ident_in_sig - else (pop_current_mid false) in + let id, md, env = pop_current_mid () in let tm = Tstr_module {mb_id=id; mb_name={txt=Ident.name id; loc=Location.none}; @@ -190,14 +182,14 @@ let extract_open od in_sig = | _ -> assert false let extract_open_struct = function - | Tstr_open od -> extract_open od false + | Tstr_open od -> extract_open od | _ -> None -let type_open ?toplevel env sod in_sig = +let type_open ?toplevel env sod = let (tme, newenv) = Builtin_attributes.warning_scope sod.popen_attributes (fun () -> - type_open_ ?toplevel in_sig sod.popen_override env sod.popen_loc + type_open_ ?toplevel sod.popen_override env sod.popen_loc sod.popen_expr ) in @@ -661,7 +653,7 @@ and approx_sig env ssg = let (id, newenv) = Env.enter_modtype d.pmtd_name.txt info env in Sig_modtype(id, info) :: approx_sig newenv srem | Psig_open sod -> - let (mty, _od) = type_open env sod true in + let (mty, _od) = type_open env sod in approx_sig mty srem | Psig_include sincl -> let smty = sincl.pincl_mod in @@ -943,13 +935,13 @@ and transl_signature env sg = sg :: rem, final_env | Psig_open sod -> begin - let (newenv, od) = type_open env sod true in + let (newenv, od) = type_open env sod in let (trem, rem, final_env) = transl_sig newenv srem in let remr = ref rem in begin - if !open_struct_level = 0 then + if not (in_nested_struct ()) then begin - match extract_open od true with + match extract_open od with | None -> () | Some (_, _, id, _) -> begin let s_rem = Mty_signature rem in begin @@ -1683,7 +1675,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = in Tstr_modtype mtd, [sg], newenv | Pstr_open sod -> - let (newenv, od) = type_open ~toplevel env sod false in + let (newenv, od) = type_open ~toplevel env sod in Tstr_open od, [], newenv | Pstr_class cl -> List.iter @@ -1781,7 +1773,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = let md_sig = Sig_module (id, {md_type=md.Types.md_type; md_loc=loc; md_attributes = []}, Trec_not) in - if !open_struct_level = 0 then begin + if not (in_nested_struct ()) then begin let s_rem = Mty_signature sig_rem in begin match Mtype.nondep_supertype new_env id s_rem with | Mty_signature sg -> @@ -1806,7 +1798,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = let previous_saved_types = Cmt_format.get_saved_types () in let run () = let (items, sg, full_sg, final_env) = type_struct env sstr in - if !open_struct_level <> 0 then begin + if in_nested_struct () then begin push_mod_type (Mty_signature full_sg) end; let str = { str_items = items; str_type = sg; str_final_env = final_env } in @@ -1914,7 +1906,7 @@ let type_package env m p nl = (* Fill in the forward declarations *) let type_open ?used_slot ovf env loc me = - type_open_ ?used_slot ?toplevel:None false ovf env loc me + type_open_ ?used_slot ?toplevel:None ovf env loc me let () = Typecore.type_module := type_module_alias; diff --git a/typing/typemod.mli b/typing/typemod.mli index 462234ad61e0..535e286f2bad 100644 --- a/typing/typemod.mli +++ b/typing/typemod.mli @@ -36,7 +36,7 @@ val transl_signature: val check_nongen_schemes: Env.t -> Types.signature -> unit val type_open_: - ?used_slot:bool ref -> ?toplevel:bool -> bool -> + ?used_slot:bool ref -> ?toplevel:bool -> Asttypes.override_flag -> Env.t -> Location.t -> Parsetree.module_expr -> Typedtree.module_expr * Env.t val modtype_of_package: From 7956bc7a39f616a47de1eb8f82dc24631868c7aa Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Mon, 20 Nov 2017 23:09:51 -0800 Subject: [PATCH 04/39] Add tests. --- testsuite/tests/typing-modules/open-struct.ml | 35 ++++++++++++++++++- 1 file changed, 34 insertions(+), 1 deletion(-) diff --git a/testsuite/tests/typing-modules/open-struct.ml b/testsuite/tests/typing-modules/open-struct.ml index 43970d05ad49..55c1d4fc4ef2 100644 --- a/testsuite/tests/typing-modules/open-struct.ml +++ b/testsuite/tests/typing-modules/open-struct.ml @@ -63,7 +63,7 @@ end let () = inc(); inc(); dec (); - assert (current () = 1) + assert (current () = 2) [%%expect{| |}];; @@ -73,6 +73,39 @@ Line _, characters 15-41: Error: The module identifier M#7 cannot be eliminated from val x : M#7.t |}];; +module A = struct + open struct + open struct + type t = T + let x = T + end + let y = x + end +end +[%%expect{| +module A : sig end +|}];; + +module type S = sig open struct type t = T end val x : t end +[%%expect{| +Line _, characters 20-46: +Error: The module identifier M#10 cannot be eliminated from val x : M#10.t +|}];; + +module type S = sig + open struct + type t = int + open struct + type s = T | A of t + end + val x : char + end + val y : t +end +[%%expect{| +module type S = sig val y : int end +|}] + module type S = sig open struct assert false end end;; [%%expect{| module type S = sig end From 20e94eb96d7d65ef499e62093abd7d6ae9f2f196 Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Thu, 23 Nov 2017 14:34:42 -0800 Subject: [PATCH 05/39] Improve tests. --- testsuite/tests/typing-modules/open-struct.ml | 81 +++++++++++++++++-- 1 file changed, 76 insertions(+), 5 deletions(-) diff --git a/testsuite/tests/typing-modules/open-struct.ml b/testsuite/tests/typing-modules/open-struct.ml index 55c1d4fc4ef2..ca5f825a0cc7 100644 --- a/testsuite/tests/typing-modules/open-struct.ml +++ b/testsuite/tests/typing-modules/open-struct.ml @@ -1,9 +1,15 @@ type t = A +[%%expect{| +type t = A +|}] module M = struct open struct type t' = t end type t = B of t * t' | C end +[%%expect{| +module M : sig type t = B of t * t | C end +|}] (* test *) include struct @@ -11,10 +17,8 @@ include struct let test = B (B (C, A), A) end [%%expect{| -type t = A -module M : sig type t = B of t * t | C end val test : M.t = M.B (M.B (M.C, A), A) -|}];; +|}] include struct open struct let aux x y = x / y end @@ -45,12 +49,14 @@ module type S = sig type t = t' -> int end val x : t end +[%%expect{| +module type S = sig val x : char -> int end +|}];; module M : S = struct let x = Char.code end [%%expect{| -module type S = sig val x : char -> int end module M : S |}];; @@ -63,7 +69,7 @@ end let () = inc(); inc(); dec (); - assert (current () = 2) + assert (current () = 1) [%%expect{| |}];; @@ -132,3 +138,68 @@ module type T = sig type s = int end module F : functor (X : S) -> T module G : functor (X : T) -> S |}] + +module Counter : sig val inc : unit -> unit val current : unit -> int val z : int val zz : int end = struct + open struct let counter = ref 0 end + let x = 1 + let y = 2 + let dec () = decr counter + + open struct + module A : sig val z : int end = struct + open struct + let n = 3 + module A = struct + open struct + let x = 1 + end + let y = x + end + let h = A.y + let g = A.y + n + end + let z = h + g + end + + let z = 12 + + module B : sig val z : int end = struct + open struct + module A = struct + open struct let x = 1 end + let y = x + open struct let x = 1 end + let z = y + x + end + let h = A.y + let g = A.z + 1 + end + let z = h + g + end + + let h = A.z + B.z + end + + let z = z + h + let g = 1 + let ggg = 2 + let inc () = incr counter + let zz = 5 + let current () = !counter +end +[%%expect{| +module Counter : + sig + val inc : unit -> unit + val current : unit -> int + val z : int + val zz : int + end +|}] + +let () = begin + assert (Counter.z = 21) +end +[%%expect{| +|}] + From 4dde10b26ee692a25f9062ac41e1e09e7b041841 Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Thu, 23 Nov 2017 16:13:53 -0800 Subject: [PATCH 06/39] Fix leaked signature. --- typing/typemod.ml | 64 ++++++++++++++++++++++++++++++++--------------- 1 file changed, 44 insertions(+), 20 deletions(-) diff --git a/typing/typemod.ml b/typing/typemod.ml index 0a1997e9f46c..9b4903317fe1 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -108,14 +108,6 @@ let gen_mod_ident () = let ident = Ident.create (Printf.sprintf "M#%d" n) in ident -let saved_full_mod_types = ref [] -let push_mod_type mt = - saved_full_mod_types := mt :: !saved_full_mod_types -let pop_mod_type () = - let mt = List.hd !saved_full_mod_types in - saved_full_mod_types := List.tl !saved_full_mod_types; - mt - let open_struct_level = ref 0 let in_nested_struct () = !open_struct_level <> 0 let enter_struct () = incr open_struct_level @@ -153,9 +145,8 @@ let type_open_ ?used_slot ?toplevel ovf env loc me = | Mty_signature _ -> () | _ -> raise(Error(me.pmod_loc, env, Invalid_open me)); end; - let full_modtype = pop_mod_type () in let md = { - md_type = full_modtype; + md_type = tme.mod_type; md_loc = me.pmod_loc; md_attributes = me.pmod_attributes; } in @@ -763,6 +754,25 @@ let simplify_signature sg = let (sg, _) = aux sg in sg + +let remove_inserted_modtype mty = + let remove_inserted_modtype = + List.filter ( + function + | Sig_module({Ident.name}, _, _) when String.contains name '#' -> false + | _ -> true) in + let rec aux = function + | Mty_signature sg -> Mty_signature (remove_inserted_modtype sg) + | Mty_functor (id, mty_arg, mty_res) -> + Mty_functor (id, + (match mty_arg with + | None -> None + | Some mty -> Some (aux mty)), + (aux mty_res)) + | mty -> mty in + aux mty + + (* Check and translate a module type expression *) let transl_modtype_longident loc env lid = @@ -1598,7 +1608,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = mb_attributes=attrs; mb_loc=pmb_loc; }, [Sig_module(id, - {md_type = modl.mod_type; + {md_type = remove_inserted_modtype modl.mod_type; md_attributes = attrs; md_loc = pmb_loc; }, Trec_not)], @@ -1774,14 +1784,14 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = Sig_module (id, {md_type=md.Types.md_type; md_loc=loc; md_attributes = []}, Trec_not) in if not (in_nested_struct ()) then begin - let s_rem = Mty_signature sig_rem in begin - match Mtype.nondep_supertype new_env id s_rem with + let fs_rem = Mty_signature fsig_rem in begin + match Mtype.nondep_supertype new_env id fs_rem with | Mty_signature sg -> (tm_str :: open_str :: str_rem, sg, - md_sig :: fsig_rem, final_env) + md_sig :: sg, final_env) | exception Not_found -> raise(Error(pstr.pstr_loc, env, - Cannot_eliminate_anon_module(id, sig_rem))) + Cannot_eliminate_anon_module(id, fsig_rem))) | _ -> assert false end end else @@ -1798,13 +1808,10 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = let previous_saved_types = Cmt_format.get_saved_types () in let run () = let (items, sg, full_sg, final_env) = type_struct env sstr in - if in_nested_struct () then begin - push_mod_type (Mty_signature full_sg) - end; let str = { str_items = items; str_type = sg; str_final_env = final_env } in Cmt_format.set_saved_types (Cmt_format.Partial_structure str :: previous_saved_types); - str, sg, final_env + str, full_sg, final_env in if toplevel then run () else Builtin_attributes.warning_scope [] run @@ -1920,6 +1927,23 @@ let () = (* Typecheck an implementation file *) +let simplify_signature sg = + let rec aux = function + | [] -> [], StringSet.empty + | (Sig_value(id, _descr) as component) :: sg -> + let (sg, val_names) as k = aux sg in + let name = Ident.name id in + if StringSet.mem name val_names then k + else (component :: sg, StringSet.add name val_names) + | Sig_module({Ident.name}, _, _) :: sg + when String.contains name '#' -> aux sg + | component :: sg -> + let (sg, val_names) = aux sg in + (component :: sg, val_names) + in + let (sg, _) = aux sg in + sg + let type_implementation sourcefile outputprefix modulename initial_env ast = Cmt_format.clear (); try @@ -1929,7 +1953,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = Warnings.parse_options false "-32-34-37-38-60"; let (str, sg, finalenv) = type_structure initial_env ast (Location.in_file sourcefile) in - let simple_sg = simplify_signature sg in + let simple_sg = simplify_signature sg in if !Clflags.print_types then begin Typecore.force_delayed_checks (); Printtyp.wrap_printing_env initial_env From 96ebd2804d9050ce6f2b9763920f641b9c3b9212 Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Thu, 23 Nov 2017 16:14:03 -0800 Subject: [PATCH 07/39] Add tests. --- testsuite/tests/typing-modules/open-struct.ml | 23 +++++++++++++++++-- testsuite/w7.ml | 0 2 files changed, 21 insertions(+), 2 deletions(-) create mode 100644 testsuite/w7.ml diff --git a/testsuite/tests/typing-modules/open-struct.ml b/testsuite/tests/typing-modules/open-struct.ml index ca5f825a0cc7..482186e52884 100644 --- a/testsuite/tests/typing-modules/open-struct.ml +++ b/testsuite/tests/typing-modules/open-struct.ml @@ -46,7 +46,8 @@ module type S = sig open struct type t' = char end - type t = t' -> int end + type t = t' -> int + end val x : t end [%%expect{| @@ -66,6 +67,8 @@ open struct let dec () = decr counter let current () = !counter end +[%%expect{| +|}] let () = inc(); inc(); dec (); @@ -92,12 +95,28 @@ end module A : sig end |}];; +module A = struct + open struct + open struct + type t = T + end + let y = T + end + let g = y +end +[%%expect{| +Line _, characters 2-74: +Error: The module identifier M#10 cannot be eliminated from val g : + M#10.M#11.t +|}] + module type S = sig open struct type t = T end val x : t end [%%expect{| Line _, characters 20-46: -Error: The module identifier M#10 cannot be eliminated from val x : M#10.t +Error: The module identifier M#12 cannot be eliminated from val x : M#12.t |}];; + module type S = sig open struct type t = int diff --git a/testsuite/w7.ml b/testsuite/w7.ml new file mode 100644 index 000000000000..e69de29bb2d1 From 81cef4126c30dd8af8daed0f67560d7da6f39eef Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Fri, 1 Dec 2017 12:25:33 -0800 Subject: [PATCH 08/39] Correct `open` for module sig. Check if we can eliminate identifier in module sig no matter if we are in nested open. --- testsuite/tests/typing-modules/open-struct.ml | 33 +++++++++++++++++++ typing/typemod.ml | 33 ++++++++----------- 2 files changed, 47 insertions(+), 19 deletions(-) diff --git a/testsuite/tests/typing-modules/open-struct.ml b/testsuite/tests/typing-modules/open-struct.ml index 482186e52884..f611fddaa6b3 100644 --- a/testsuite/tests/typing-modules/open-struct.ml +++ b/testsuite/tests/typing-modules/open-struct.ml @@ -222,3 +222,36 @@ end [%%expect{| |}] +module N = struct + open (functor + (N: sig open struct type t = int end val x : t end) -> + (struct let y = N.x end))(struct let x = 1 end) + + let () = + assert(y = 1) +end +[%%expect{| +module N : sig end +|}] + +module M = struct + open struct + open struct + module type S = sig open struct type t = int end val x : t end + module M : S = struct let x = 1 end + end + end +end +[%%expect{| +module M : sig end +|}] + +module N = struct + open struct + module type S = sig open struct type t = T end val x : t end + end +end +[%%expect{| +Line _, characters 24-50: +Error: The module identifier M#31 cannot be eliminated from val x : M#31.t +|}] diff --git a/typing/typemod.ml b/typing/typemod.ml index 9b4903317fe1..18b447fae039 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -756,13 +756,13 @@ let simplify_signature sg = let remove_inserted_modtype mty = - let remove_inserted_modtype = + let remove = List.filter ( function | Sig_module({Ident.name}, _, _) when String.contains name '#' -> false | _ -> true) in let rec aux = function - | Mty_signature sg -> Mty_signature (remove_inserted_modtype sg) + | Mty_signature sg -> Mty_signature (remove sg) | Mty_functor (id, mty_arg, mty_res) -> Mty_functor (id, (match mty_arg with @@ -948,23 +948,18 @@ and transl_signature env sg = let (newenv, od) = type_open env sod in let (trem, rem, final_env) = transl_sig newenv srem in let remr = ref rem in - begin - if not (in_nested_struct ()) then - begin - match extract_open od with - | None -> () - | Some (_, _, id, _) -> begin - let s_rem = Mty_signature rem in begin - match Mtype.nondep_supertype newenv id s_rem with - | Mty_signature rem' -> remr := rem' - | exception Not_found -> - raise(Error(sod.popen_loc, env, - Cannot_eliminate_anon_module(id, rem))) - | _ -> assert false - end - end - end else () - end; + (match extract_open od with + | None -> () + | Some (_, _, id, _) -> begin + let s_rem = Mty_signature rem in begin + match Mtype.nondep_supertype newenv id s_rem with + | Mty_signature rem' -> remr := rem' + | exception Not_found -> + raise(Error(sod.popen_loc, env, + Cannot_eliminate_anon_module(id, rem))) + | _ -> assert false + end + end); mksig (Tsig_open od) env loc :: trem, !remr, final_env end From 632fd78f45dc6f1a631879014719393da5faa1c2 Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Fri, 1 Dec 2017 15:52:10 -0800 Subject: [PATCH 09/39] remove a whitespace --- typing/typemod.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/typing/typemod.ml b/typing/typemod.ml index 18b447fae039..a91905606fb9 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -1948,7 +1948,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = Warnings.parse_options false "-32-34-37-38-60"; let (str, sg, finalenv) = type_structure initial_env ast (Location.in_file sourcefile) in - let simple_sg = simplify_signature sg in + let simple_sg = simplify_signature sg in if !Clflags.print_types then begin Typecore.force_delayed_checks (); Printtyp.wrap_printing_env initial_env From 63e127c7cdbd7bf0ed2ea76021184f285c3ba5af Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Fri, 1 Dec 2017 17:06:05 -0800 Subject: [PATCH 10/39] Add Change entry. --- Changes | 3 +++ 1 file changed, 3 insertions(+) diff --git a/Changes b/Changes index c412f5f3c440..fd6080d4bbbd 100644 --- a/Changes +++ b/Changes @@ -10,6 +10,9 @@ Working version (Nicolas Ojeda Bar, review by Gabriel Radanne, Damien Doligez, Gabriel Scherer) +- GPR#1506: Extending `open` to accept arbitrary module expression + (Runhang Li, review by Jeremy Yallop) + ### Type system: - GPR#1370: Fix code duplication in Cmmgen From db4a5986f962d0931b7ea4425f11dd2cc72c7149 Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Thu, 18 Jan 2018 06:42:08 -0800 Subject: [PATCH 11/39] Do not use stack --- driver/compmisc.ml | 3 +- ocamldoc/odoc_analyse.ml | 3 +- typing/typemod.ml | 687 ++++++++++++++++++++------------------- typing/typemod.mli | 4 +- 4 files changed, 364 insertions(+), 333 deletions(-) diff --git a/driver/compmisc.ml b/driver/compmisc.ml index bb162511bf0d..d31d6c6dd1e4 100644 --- a/driver/compmisc.ml +++ b/driver/compmisc.ml @@ -48,7 +48,8 @@ let open_implicit_module m env = let loc = Location.in_file "command line" in let lid = {loc; txt = Longident.parse m } in let me = Parsetree.({pmod_desc=Pmod_ident lid; pmod_loc=loc; pmod_attributes=[]}) in - snd (Typemod.type_open_ ?toplevel:None Override env lid.loc me) + let _, _, env = (Typemod.type_open_ ?toplevel:None Override env lid.loc me) in + env let initial_env () = Ident.reinit(); diff --git a/ocamldoc/odoc_analyse.ml b/ocamldoc/odoc_analyse.ml index b29921f5b22f..8858b531312c 100644 --- a/ocamldoc/odoc_analyse.ml +++ b/ocamldoc/odoc_analyse.ml @@ -44,7 +44,8 @@ let initial_env () = let lid = {loc; txt = Longident.parse m } in let me = Parsetree.({pmod_desc=Pmod_ident lid; pmod_loc=loc; pmod_attributes=[]}) in - snd (Typemod.type_open_ ?toplevel:None Override env lid.loc me) in + let _, _, env = (Typemod.type_open_ ?toplevel:None Override env lid.loc me) in + env in (* Open the list of modules given as arguments of the "-open" flag The list is reversed to open the modules in the left-to-right order *) let to_open = List.rev !Clflags.open_modules in diff --git a/typing/typemod.ml b/typing/typemod.ml index a91905606fb9..6cb1a514b87c 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -92,15 +92,6 @@ let type_module_fwd : (Env.t -> Parsetree.module_expr -> ref (fun _ _ -> assert false) let mod_ident_counter = ref 0 -let generated_module_ident = ref [] - -let push_current_mid (mi, md, env) = - generated_module_ident := (mi, md, env) :: !generated_module_ident - -let pop_current_mid () = - let slot = List.hd !generated_module_ident in - generated_module_ident := List.tl !generated_module_ident; - slot let gen_mod_ident () = let n = !mod_ident_counter in @@ -129,7 +120,7 @@ let type_open_ ?used_slot ?toplevel ovf env loc me = mod_env=env; mod_attributes=me.pmod_attributes } in - tme, env + None, tme, env | None -> let md = Env.find_module path env in ignore (extract_sig_open env lid.loc md.md_type); @@ -151,33 +142,14 @@ let type_open_ ?used_slot ?toplevel ovf env loc me = md_attributes = me.pmod_attributes; } in let newenv = Env.enter_module_declaration ident md env in - push_current_mid (ident, md, newenv); let root = Pident ident in match Env.open_signature ~loc ?used_slot ?toplevel ovf root newenv with | None -> assert false - | Some opened_env -> tme, opened_env + | Some opened_env -> Some (ident, md, newenv), tme, opened_env end -let extract_open od = - match od.open_expr.mod_desc with - | Tmod_ident (_, _) -> None - | Tmod_structure _ | Tmod_apply _ | Tmod_constraint _ -> - let id, md, env = pop_current_mid () in - let tm = - Tstr_module {mb_id=id; - mb_name={txt=Ident.name id; loc=Location.none}; - mb_expr = od.open_expr; - mb_attributes=od.open_expr.mod_attributes; - mb_loc=od.open_expr.mod_loc} in - Some (tm, md, id, env) - | _ -> assert false - -let extract_open_struct = function - | Tstr_open od -> extract_open od - | _ -> None - let type_open ?toplevel env sod = - let (tme, newenv) = + let (md, tme, newenv) = Builtin_attributes.warning_scope sod.popen_attributes (fun () -> type_open_ ?toplevel sod.popen_override env sod.popen_loc @@ -192,7 +164,7 @@ let type_open ?toplevel env sod = open_loc = sod.popen_loc; } in - newenv, od + md, newenv, od (* Record a module type *) let rm node = @@ -644,7 +616,7 @@ and approx_sig env ssg = let (id, newenv) = Env.enter_modtype d.pmtd_name.txt info env in Sig_modtype(id, info) :: approx_sig newenv srem | Psig_open sod -> - let (mty, _od) = type_open env sod in + let (_id, mty, _od) = type_open env sod in approx_sig mty srem | Psig_include sincl -> let smty = sincl.pincl_mod in @@ -798,6 +770,11 @@ let mksig desc env loc = Cmt_format.add_saved_type (Cmt_format.Partial_signature_item sg); sg +let mkstr str env loc = + let str = { str_desc = str; str_loc = loc; str_env = env } in + Cmt_format.add_saved_type (Cmt_format.Partial_structure_item str); + str + (* let signature sg = List.map (fun item -> item.sig_type) sg *) let rec transl_modtype env smty = @@ -945,23 +922,19 @@ and transl_signature env sg = sg :: rem, final_env | Psig_open sod -> begin - let (newenv, od) = type_open env sod in + let (id, newenv, od) = type_open env sod in let (trem, rem, final_env) = transl_sig newenv srem in - let remr = ref rem in - (match extract_open od with - | None -> () - | Some (_, _, id, _) -> begin - let s_rem = Mty_signature rem in begin - match Mtype.nondep_supertype newenv id s_rem with - | Mty_signature rem' -> remr := rem' - | exception Not_found -> - raise(Error(sod.popen_loc, env, - Cannot_eliminate_anon_module(id, rem))) - | _ -> assert false - end - end); - mksig (Tsig_open od) env loc :: trem, - !remr, final_env + match id with + | None -> mksig (Tsig_open od) env loc :: trem, rem, final_env + | Some (id, _md, _env) -> + let s_rem = Mty_signature rem in + match Mtype.nondep_supertype newenv id s_rem with + | Mty_signature rem' -> + mksig (Tsig_open od) env loc :: trem, rem', final_env + | exception Not_found -> + raise(Error(sod.popen_loc, env, + Cannot_eliminate_anon_module(id, rem))) + | _ -> assert false end | Psig_include sincl -> let smty = sincl.pincl_mod in @@ -1514,299 +1487,350 @@ and type_module_aux ~alias sttn funct_body anchor env smod = and type_structure ?(toplevel = false) funct_body anchor env sstr scope = let names = new_names () in - let type_str_item env srem {pstr_loc = loc; pstr_desc = desc} = - match desc with - | Pstr_eval (sexpr, attrs) -> - let expr = - Builtin_attributes.warning_scope attrs - (fun () -> Typecore.type_expression env sexpr) - in - Tstr_eval (expr, attrs), [], env - | Pstr_value(rec_flag, sdefs) -> - let scope = - match rec_flag with - | Recursive -> - Some (Annot.Idef {scope with - Location.loc_start = loc.Location.loc_start}) - | Nonrecursive -> - let start = - match srem with - | [] -> loc.Location.loc_end - | {pstr_loc = loc2} :: _ -> loc2.Location.loc_start - in - Some (Annot.Idef {scope with Location.loc_start = start}) - in - let (defs, newenv) = - Typecore.type_binding env rec_flag sdefs scope in - let () = if rec_flag = Recursive then - Typecore.check_recursive_bindings env defs - in - (* Note: Env.find_value does not trigger the value_used event. Values - will be marked as being used during the signature inclusion test. *) - Tstr_value(rec_flag, defs), - List.map (fun id -> Sig_value(id, Env.find_value (Pident id) newenv)) - (let_bound_idents defs), - newenv - | Pstr_primitive sdesc -> - let (desc, newenv) = Typedecl.transl_value_decl env loc sdesc in - Tstr_primitive desc, [Sig_value(desc.val_id, desc.val_val)], newenv - | Pstr_type (rec_flag, sdecls) -> - List.iter - (fun decl -> check_name check_type names decl.ptype_name) - sdecls; - let (decls, newenv) = Typedecl.transl_type_decl env rec_flag sdecls in - Tstr_type (rec_flag, decls), - map_rec_type_with_row_types ~rec_flag - (fun rs info -> Sig_type(info.typ_id, info.typ_type, rs)) - decls [], - enrich_type_decls anchor decls env newenv - | Pstr_typext styext -> - List.iter - (fun pext -> check_name check_typext names pext.pext_name) - styext.ptyext_constructors; - let (tyext, newenv) = - Typedecl.transl_type_extension true env loc styext - in - (Tstr_typext tyext, - map_ext - (fun es ext -> Sig_typext(ext.ext_id, ext.ext_type, es)) - tyext.tyext_constructors [], - newenv) - | Pstr_exception sext -> - check_name check_typext names sext.pext_name; - let (ext, newenv) = Typedecl.transl_exception env sext in - Tstr_exception ext, - [Sig_typext(ext.ext_id, ext.ext_type, Text_exception)], - newenv - | Pstr_module {pmb_name = name; pmb_expr = smodl; pmb_attributes = attrs; - pmb_loc; - } -> - check_name check_module names name; - let id = Ident.create name.txt in (* create early for PR#6752 *) - let modl = - Builtin_attributes.warning_scope attrs - (fun () -> - type_module ~alias:true true funct_body - (anchor_submodule name.txt anchor) env smodl - ) - in - let md = - { md_type = enrich_module_type anchor name.txt modl.mod_type env; - md_attributes = attrs; - md_loc = pmb_loc; - } - in - (*prerr_endline (Ident.unique_toplevel_name id);*) - Mtype.lower_nongen (Ident.binding_time id - 1) md.md_type; - let newenv = Env.enter_module_declaration id md env in - Tstr_module {mb_id=id; mb_name=name; mb_expr=modl; - mb_attributes=attrs; mb_loc=pmb_loc; - }, - [Sig_module(id, - {md_type = remove_inserted_modtype modl.mod_type; - md_attributes = attrs; - md_loc = pmb_loc; - }, Trec_not)], - newenv - | Pstr_recmodule sbind -> - let sbind = - List.map - (function - | {pmb_name = name; - pmb_expr = {pmod_desc=Pmod_constraint(expr, typ)}; - pmb_attributes = attrs; - pmb_loc = loc; - } -> - name, typ, expr, attrs, loc - | mb -> - raise (Error (mb.pmb_expr.pmod_loc, env, - Recursive_module_require_explicit_type)) - ) - sbind - in - List.iter - (fun (name, _, _, _, _) -> check_name check_module names name) - sbind; - let (decls, newenv) = - transl_recmodule_modtypes env - (List.map (fun (name, smty, _smodl, attrs, loc) -> - {pmd_name=name; pmd_type=smty; - pmd_attributes=attrs; pmd_loc=loc}) sbind - ) in - let bindings1 = - List.map2 - (fun {md_id=id; md_type=mty} (name, _, smodl, attrs, loc) -> - let modl = - Builtin_attributes.warning_scope attrs - (fun () -> - type_module true funct_body (anchor_recmodule id) - newenv smodl - ) - in - let mty' = - enrich_module_type anchor (Ident.name id) modl.mod_type newenv - in - (id, name, mty, modl, mty', attrs, loc)) - decls sbind in - let newenv = (* allow aliasing recursive modules from outside *) - List.fold_left - (fun env md -> - let mdecl = - { - md_type = md.md_type.mty_type; - md_attributes = md.md_attributes; - md_loc = md.md_loc; - } - in - Env.add_module_declaration ~check:true md.md_id mdecl env - ) - env decls - in - let bindings2 = - check_recmodule_inclusion newenv bindings1 in - Tstr_recmodule bindings2, - map_rec (fun rs mb -> - Sig_module(mb.mb_id, { - md_type=mb.mb_expr.mod_type; - md_attributes=mb.mb_attributes; - md_loc=mb.mb_loc; - }, rs)) - bindings2 [], - newenv - | Pstr_modtype pmtd -> - (* check that it is non-abstract *) - let newenv, mtd, sg = - transl_modtype_decl names env pmtd - in - Tstr_modtype mtd, [sg], newenv - | Pstr_open sod -> - let (newenv, od) = type_open ~toplevel env sod in - Tstr_open od, [], newenv - | Pstr_class cl -> - List.iter - (fun {pci_name} -> check_name check_type names pci_name) - cl; - let (classes, new_env) = Typeclass.class_declarations env cl in - Tstr_class - (List.map (fun cls -> - (cls.Typeclass.cls_info, - cls.Typeclass.cls_pub_methods)) classes), -(* TODO: check with Jacques why this is here - Tstr_class_type - (List.map (fun (_,_, i, d, _,_,_,_,_,_,c) -> (i, c)) classes) :: - Tstr_type - (List.map (fun (_,_,_,_, i, d, _,_,_,_,_) -> (i, d)) classes) :: - Tstr_type - (List.map (fun (_,_,_,_,_,_, i, d, _,_,_) -> (i, d)) classes) :: -*) - List.flatten - (map_rec - (fun rs cls -> - let open Typeclass in - [Sig_class(cls.cls_id, cls.cls_decl, rs); - Sig_class_type(cls.cls_ty_id, cls.cls_ty_decl, rs); - Sig_type(cls.cls_obj_id, cls.cls_obj_abbr, rs); - Sig_type(cls.cls_typesharp_id, cls.cls_abbr, rs)]) - classes []), - new_env - | Pstr_class_type cl -> - List.iter - (fun {pci_name} -> check_name check_type names pci_name) - cl; - let (classes, new_env) = Typeclass.class_type_declarations env cl in - Tstr_class_type - (List.map (fun cl -> - (cl.Typeclass.clsty_ty_id, - cl.Typeclass.clsty_id_loc, - cl.Typeclass.clsty_info)) classes), -(* TODO: check with Jacques why this is here - Tstr_type - (List.map (fun (_, _, i, d, _, _) -> (i, d)) classes) :: - Tstr_type - (List.map (fun (_, _, _, _, i, d) -> (i, d)) classes) :: *) - List.flatten - (map_rec - (fun rs decl -> - let open Typeclass in - [Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs); - Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs); - Sig_type(decl.clsty_typesharp_id, decl.clsty_abbr, rs)]) - classes []), - new_env - | Pstr_include sincl -> - let smodl = sincl.pincl_mod in - let modl = - Builtin_attributes.warning_scope sincl.pincl_attributes - (fun () -> type_module true funct_body None env smodl) - in - (* 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 - List.iter (check_sig_item names loc) sg; - let new_env = Env.add_signature sg env in - let incl = - { incl_mod = modl; - incl_type = sg; - incl_attributes = sincl.pincl_attributes; - incl_loc = sincl.pincl_loc; - } - in - Tstr_include incl, sg, new_env - | Pstr_extension (ext, _attrs) -> - raise (Error_forward (Builtin_attributes.error_of_extension ext)) - | Pstr_attribute x -> - Builtin_attributes.warning_attribute x; - Tstr_attribute x, [], env - in let rec type_struct env sstr = - Ctype.init_def(Ident.current_time()); + Ctype.init_def (Ident.current_time()); match sstr with - | [] -> ([], [], [], env) - | pstr :: srem -> begin - let previous_saved_types = Cmt_format.get_saved_types () in - let desc, sg, new_env = type_str_item env srem pstr in - let str = { str_desc = desc; str_loc = pstr.pstr_loc; str_env = env } in - Cmt_format.set_saved_types (Cmt_format.Partial_structure_item str - :: previous_saved_types); - let (str_rem, sig_rem, fsig_rem, final_env) = type_struct new_env srem in - match extract_open_struct desc with - | Some (tm, md, id, md_env) -> begin - let loc = pstr.pstr_loc in - let tm_str = {str_desc = tm; str_loc = loc; - str_env = env} in - let open_str = {str with str_env = md_env} in - let md_sig = - Sig_module (id, {md_type=md.Types.md_type; md_loc=loc; - md_attributes = []}, Trec_not) in - if not (in_nested_struct ()) then begin - let fs_rem = Mty_signature fsig_rem in begin - match Mtype.nondep_supertype new_env id fs_rem with - | Mty_signature sg -> - (tm_str :: open_str :: str_rem, sg, - md_sig :: sg, final_env) - | exception Not_found -> - raise(Error(pstr.pstr_loc, env, - Cannot_eliminate_anon_module(id, fsig_rem))) - | _ -> assert false - end - end else - (tm_str :: open_str :: str_rem, sig_rem, - md_sig :: fsig_rem, final_env) + | [] -> ([], [], env) + | {pstr_desc = desc; pstr_loc = loc} :: srem -> + match desc with + | Pstr_eval (sexpr, attrs) -> + let expr = + Builtin_attributes.warning_scope attrs + (fun () -> Typecore.type_expression env sexpr) + in + let str_rem, sig_rem, final_env = type_struct env srem in + mkstr (Tstr_eval (expr, attrs)) env loc :: str_rem, + sig_rem, final_env + | Pstr_value(rec_flag, sdefs) -> + let scope = + match rec_flag with + | Recursive -> + Some (Annot.Idef {scope with + Location.loc_start = loc.Location.loc_start}) + | Nonrecursive -> + let start = + match srem with + | [] -> loc.Location.loc_end + | {pstr_loc = loc2} :: _ -> loc2.Location.loc_start + in + Some (Annot.Idef {scope with Location.loc_start = start}) + in + let (defs, newenv) = + Typecore.type_binding env rec_flag sdefs scope in + let () = if rec_flag = Recursive then + Typecore.check_recursive_bindings env defs + in + let str_rem, sig_rem, final_env = type_struct newenv srem in + (* Note: Env.find_value does not trigger the value_used event. Values + will be marked as being used during the signature inclusion test. *) + mkstr (Tstr_value(rec_flag, defs)) newenv loc :: str_rem, + (List.map (fun id -> Sig_value(id, Env.find_value (Pident id) newenv)) + (let_bound_idents defs)) @ sig_rem, final_env + | Pstr_primitive sdesc -> + let (desc, newenv) = Typedecl.transl_value_decl env loc sdesc in + let str_rem, sig_rem, final_env = type_struct newenv srem in + mkstr (Tstr_primitive desc) newenv loc :: str_rem, + [Sig_value(desc.val_id, desc.val_val)] @ sig_rem, final_env + | Pstr_type (rec_flag, sdecls) -> + List.iter + (fun decl -> check_name check_type names decl.ptype_name) + sdecls; + let (decls, newenv) = Typedecl.transl_type_decl env rec_flag sdecls in + let newenv = enrich_type_decls anchor decls env newenv in + let str_rem, sig_rem, final_env = type_struct newenv srem in + mkstr (Tstr_type (rec_flag, decls)) newenv loc :: str_rem, + (map_rec_type_with_row_types ~rec_flag + (fun rs info -> Sig_type(info.typ_id, info.typ_type, rs)) + decls []) @ sig_rem, final_env + | Pstr_typext styext -> + List.iter + (fun pext -> check_name check_typext names pext.pext_name) + styext.ptyext_constructors; + let (tyext, newenv) = + Typedecl.transl_type_extension true env loc styext + in + let str_rem, sig_rem, final_env = type_struct newenv srem in + mkstr (Tstr_typext tyext) newenv loc :: str_rem, + (map_ext + (fun es ext -> Sig_typext(ext.ext_id, ext.ext_type, es)) + tyext.tyext_constructors []) @ sig_rem, final_env + | Pstr_exception sext -> + check_name check_typext names sext.pext_name; + let (ext, newenv) = Typedecl.transl_exception env sext in + let str_rem, sig_rem, final_env = type_struct newenv srem in + mkstr (Tstr_exception ext) newenv loc :: str_rem, + [Sig_typext(ext.ext_id, ext.ext_type, Text_exception)] @ sig_rem, + final_env + | Pstr_module {pmb_name = name; pmb_expr = smodl; pmb_attributes = attrs; + pmb_loc; + } -> + check_name check_module names name; + let id = Ident.create name.txt in (* create early for PR#6752 *) + let modl = + Builtin_attributes.warning_scope attrs + (fun () -> + type_module ~alias:true true funct_body + (anchor_submodule name.txt anchor) env smodl + ) + in + let md = + { md_type = enrich_module_type anchor name.txt modl.mod_type env; + md_attributes = attrs; + md_loc = pmb_loc; + } + in + (*prerr_endline (Ident.unique_toplevel_name id);*) + Mtype.lower_nongen (Ident.binding_time id - 1) md.md_type; + let newenv = Env.enter_module_declaration id md env in + let str_rem, sig_rem, final_env = type_struct newenv srem in + mkstr (Tstr_module {mb_id=id; mb_name=name; mb_expr=modl; + mb_attributes=attrs; mb_loc=pmb_loc; + }) newenv loc :: str_rem, + Sig_module(id, + {md_type = remove_inserted_modtype modl.mod_type; + md_attributes = attrs; + md_loc = pmb_loc; + }, Trec_not) :: sig_rem, + final_env + | Pstr_recmodule sbind -> + let sbind = + List.map + (function + | {pmb_name = name; + pmb_expr = {pmod_desc=Pmod_constraint(expr, typ)}; + pmb_attributes = attrs; + pmb_loc = loc; + } -> + name, typ, expr, attrs, loc + | mb -> + raise (Error (mb.pmb_expr.pmod_loc, env, + Recursive_module_require_explicit_type)) + ) + sbind + in + List.iter + (fun (name, _, _, _, _) -> check_name check_module names name) + sbind; + let (decls, newenv) = + transl_recmodule_modtypes env + (List.map (fun (name, smty, _smodl, attrs, loc) -> + {pmd_name=name; pmd_type=smty; + pmd_attributes=attrs; pmd_loc=loc}) sbind + ) in + let bindings1 = + List.map2 + (fun {md_id=id; md_type=mty} (name, _, smodl, attrs, loc) -> + let modl = + Builtin_attributes.warning_scope attrs + (fun () -> + type_module true funct_body (anchor_recmodule id) + newenv smodl + ) + in + let mty' = + enrich_module_type anchor (Ident.name id) modl.mod_type newenv + in + (id, name, mty, modl, mty', attrs, loc)) + decls sbind in + let newenv = (* allow aliasing recursive modules from outside *) + List.fold_left + (fun env md -> + let mdecl = + { + md_type = md.md_type.mty_type; + md_attributes = md.md_attributes; + md_loc = md.md_loc; + } + in + Env.add_module_declaration ~check:true md.md_id mdecl env + ) + env decls + in + let str_rem, sig_rem, final_env = type_struct newenv srem in + let bindings2 = + check_recmodule_inclusion newenv bindings1 in + mkstr (Tstr_recmodule bindings2) newenv loc :: str_rem, + (map_rec (fun rs mb -> + Sig_module(mb.mb_id, { + md_type=mb.mb_expr.mod_type; + md_attributes=mb.mb_attributes; + md_loc=mb.mb_loc; + }, rs)) + bindings2 []) @ sig_rem, + final_env + | Pstr_modtype pmtd -> + (* check that it is non-abstract *) + let newenv, mtd, sg = + transl_modtype_decl names env pmtd + in + let str_rem, sig_rem, final_env = type_struct newenv srem in + mkstr (Tstr_modtype mtd) newenv loc :: str_rem, sg :: sig_rem, + final_env + | Pstr_open sod -> begin + let (md, newenv, od) = type_open ~toplevel env sod in + let str_rem, sig_rem, final_env = type_struct newenv srem in + match md with + | None -> mkstr (Tstr_open od) newenv loc :: str_rem, + sig_rem, final_env + | Some (id, md, menv) -> + let tm = + Tstr_module {mb_id=id; + mb_name={txt=Ident.name id; loc=Location.none}; + mb_expr = od.open_expr; + mb_attributes=od.open_expr.mod_attributes; + mb_loc=od.open_expr.mod_loc} in + let tm_str = { str_desc = tm; str_loc = loc; str_env = env } in + let open_str = mkstr (Tstr_open od) menv loc in + let md_sig = + Sig_module (id, {md_type=md.Types.md_type; md_loc=loc; + md_attributes = []}, Trec_not) in + if not (in_nested_struct ()) then + let s_rem = Mty_signature sig_rem in + match Mtype.nondep_supertype newenv id s_rem with + | Mty_signature sg -> + tm_str :: open_str :: str_rem, md_sig :: sg, final_env + | exception Not_found -> + raise (Error(loc, env, + Cannot_eliminate_anon_module(id, sig_rem))) + | _ -> assert false + else + tm_str :: open_str :: str_rem, md_sig :: sig_rem, final_env end - | None -> - (str :: str_rem, sg @ sig_rem, sg @ fsig_rem, final_env) + | Pstr_class cl -> + List.iter + (fun {pci_name} -> check_name check_type names pci_name) + cl; + let (classes, new_env) = Typeclass.class_declarations env cl in + let str_rem, sig_rem, final_env = type_struct new_env srem in + mkstr + (Tstr_class + (List.map (fun cls -> + (cls.Typeclass.cls_info, + cls.Typeclass.cls_pub_methods)) classes)) + new_env loc :: str_rem, + (* TODO: check with Jacques why this is here + Tstr_class_type + (List.map (fun (_,_, i, d, _,_,_,_,_,_,c) -> (i, c)) classes) :: + Tstr_type + (List.map (fun (_,_,_,_, i, d, _,_,_,_,_) -> (i, d)) classes) :: + Tstr_type + (List.map (fun (_,_,_,_,_,_, i, d, _,_,_) -> (i, d)) classes) :: + *) + (List.flatten + (map_rec + (fun rs cls -> + let open Typeclass in + [Sig_class(cls.cls_id, cls.cls_decl, rs); + Sig_class_type(cls.cls_ty_id, cls.cls_ty_decl, rs); + Sig_type(cls.cls_obj_id, cls.cls_obj_abbr, rs); + Sig_type(cls.cls_typesharp_id, cls.cls_abbr, rs)]) + classes [])) @ sig_rem, + final_env + | Pstr_class_type cl -> + List.iter + (fun {pci_name} -> check_name check_type names pci_name) + cl; + let (classes, new_env) = Typeclass.class_type_declarations env cl in + let str_rem, sig_rem, final_env = type_struct new_env srem in + mkstr + (Tstr_class_type + (List.map (fun cl -> + (cl.Typeclass.clsty_ty_id, + cl.Typeclass.clsty_id_loc, + cl.Typeclass.clsty_info)) classes)) new_env loc :: str_rem, + (* TODO: check with Jacques why this is here + Tstr_type + (List.map (fun (_, _, i, d, _, _) -> (i, d)) classes) :: + Tstr_type + (List.map (fun (_, _, _, _, i, d) -> (i, d)) classes) :: *) + (List.flatten + (map_rec + (fun rs decl -> + let open Typeclass in + [Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs); + Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs); + Sig_type(decl.clsty_typesharp_id, decl.clsty_abbr, rs)]) + classes [])) @ sig_rem, + final_env + | Pstr_include sincl -> + let smodl = sincl.pincl_mod in + let modl = + Builtin_attributes.warning_scope sincl.pincl_attributes + (fun () -> type_module true funct_body None env smodl) + in + (* 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 + List.iter (check_sig_item names loc) sg; + let new_env = Env.add_signature sg env in + let str_rem, sig_rem, final_env = type_struct new_env srem in + let incl = + { incl_mod = modl; + incl_type = sg; + incl_attributes = sincl.pincl_attributes; + incl_loc = sincl.pincl_loc; + } + in + mkstr (Tstr_include incl) new_env loc :: str_rem, + sg @ sig_rem, final_env + | Pstr_extension (ext, _attrs) -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + | Pstr_attribute x -> + Builtin_attributes.warning_attribute x; + let str_rem, sig_rem, final_env = type_struct env srem in + mkstr (Tstr_attribute x) env loc :: str_rem, sig_rem, final_env + in + (* + let rec type_struct env sstr = + Ctype.init_def(Ident.current_time()); + match sstr with + | [] -> ([], [], [], env) + | pstr :: srem -> begin + let previous_saved_types = Cmt_format.get_saved_types () in + let desc, sg, new_env = type_str_item env srem pstr in + let str = { str_desc = desc; str_loc = pstr.pstr_loc; str_env = env } in + Cmt_format.set_saved_types (Cmt_format.Partial_structure_item str + :: previous_saved_types); + let (str_rem, sig_rem, fsig_rem, final_env) = type_struct new_env srem in + match extract_open_struct desc with + | Some (tm, md, id, md_env) -> begin + let loc = pstr.pstr_loc in + let tm_str = {str_desc = tm; str_loc = loc; + str_env = env} in + let open_str = {str with str_env = md_env} in + let md_sig = + Sig_module (id, {md_type=md.Types.md_type; md_loc=loc; + md_attributes = []}, Trec_not) in + if not (in_nested_struct ()) then begin + let fs_rem = Mty_signature fsig_rem in begin + match Mtype.nondep_supertype new_env id fs_rem with + | Mty_signature sg -> + (tm_str :: open_str :: str_rem, sg, + md_sig :: sg, final_env) + | exception Not_found -> + raise(Error(pstr.pstr_loc, env, + Cannot_eliminate_anon_module(id, fsig_rem))) + | _ -> assert false + end + end else + (tm_str :: open_str :: str_rem, sig_rem, + md_sig :: fsig_rem, final_env) + end + | None -> + (str :: str_rem, sg @ sig_rem, sg @ fsig_rem, final_env) end in + *) if !Clflags.annotations then (* moved to genannot *) List.iter (function {pstr_loc = l} -> Stypes.record_phrase l) sstr; let previous_saved_types = Cmt_format.get_saved_types () in let run () = - let (items, sg, full_sg, final_env) = type_struct env sstr in + let (items, sg, final_env) = type_struct env sstr in let str = { str_items = items; str_type = sg; str_final_env = final_env } in Cmt_format.set_saved_types (Cmt_format.Partial_structure str :: previous_saved_types); - str, full_sg, final_env + str, sg, final_env in if toplevel then run () else Builtin_attributes.warning_scope [] run @@ -1908,7 +1932,10 @@ let type_package env m p nl = (* Fill in the forward declarations *) let type_open ?used_slot ovf env loc me = - type_open_ ?used_slot ?toplevel:None ovf env loc me + let md, tme, env = type_open_ ?used_slot ?toplevel:None ovf env loc me in + match md with + | None -> tme, env + | Some _ -> assert false let () = Typecore.type_module := type_module_alias; diff --git a/typing/typemod.mli b/typing/typemod.mli index 535e286f2bad..5b0b9f2a3b17 100644 --- a/typing/typemod.mli +++ b/typing/typemod.mli @@ -38,7 +38,9 @@ val check_nongen_schemes: val type_open_: ?used_slot:bool ref -> ?toplevel:bool -> Asttypes.override_flag -> Env.t -> Location.t -> - Parsetree.module_expr -> Typedtree.module_expr * Env.t + Parsetree.module_expr -> + (Ident.t * Types.module_declaration * Env.t) option * + Typedtree.module_expr * Env.t val modtype_of_package: Env.t -> Location.t -> Path.t -> Longident.t list -> type_expr list -> module_type From 9703a92ea88d3cb4274d7c5987c0af552fcd4ff7 Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Sat, 20 Jan 2018 17:22:12 -0800 Subject: [PATCH 12/39] add comments, use protect_refs, etc --- driver/compmisc.ml | 4 +- parsing/ast_invariants.ml | 3 +- typing/typemod.ml | 231 ++++++++++++++++---------------------- 3 files changed, 100 insertions(+), 138 deletions(-) diff --git a/driver/compmisc.ml b/driver/compmisc.ml index d31d6c6dd1e4..60fe7c34d00a 100644 --- a/driver/compmisc.ml +++ b/driver/compmisc.ml @@ -47,8 +47,8 @@ let open_implicit_module m env = let open Asttypes in let loc = Location.in_file "command line" in let lid = {loc; txt = Longident.parse m } in - let me = Parsetree.({pmod_desc=Pmod_ident lid; pmod_loc=loc; pmod_attributes=[]}) in - let _, _, env = (Typemod.type_open_ ?toplevel:None Override env lid.loc me) in + let me = Ast_helper.Mod.ident ~loc ~attrs:[] lid in + let _, _, env = (Typemod.type_open_ ?toplevel:None Override env loc me) in env let initial_env () = diff --git a/parsing/ast_invariants.ml b/parsing/ast_invariants.ml index 834a792ddcb9..536710cb14ea 100644 --- a/parsing/ast_invariants.ml +++ b/parsing/ast_invariants.ml @@ -116,8 +116,7 @@ let iterator = | _ -> () in let open_description self opn = - super.open_description self opn; - super.module_expr self opn.popen_expr + super.open_description self opn in let with_constraint self wc = super.with_constraint self wc; diff --git a/typing/typemod.ml b/typing/typemod.ml index 6cb1a514b87c..295133f5b5ee 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -104,9 +104,11 @@ let in_nested_struct () = !open_struct_level <> 0 let enter_struct () = incr open_struct_level let leave_struct () = decr open_struct_level +let open_generated s = String.contains s '#' + let type_open_ ?used_slot ?toplevel ovf env loc me = match me.pmod_desc with - | Pmod_functor _ | Pmod_unpack _ | Pmod_extension _ -> + | Pmod_functor _ | Pmod_extension _ -> raise(Error(me.pmod_loc, env, Invalid_open me)) | Pmod_ident lid -> begin let path = Typetexp.lookup_module ~load:true env lid.loc lid.txt in @@ -126,16 +128,15 @@ let type_open_ ?used_slot ?toplevel ovf env loc me = ignore (extract_sig_open env lid.loc md.md_type); assert false end - | _ -> begin + | Pmod_structure _ | Pmod_apply _ | Pmod_constraint _ | Pmod_unpack _ -> enter_struct (); let ident = gen_mod_ident () in let tme = !type_module_fwd env me in leave_struct (); - begin - match tme.mod_type with - | Mty_signature _ -> () - | _ -> raise(Error(me.pmod_loc, env, Invalid_open me)); - end; + (match tme.mod_type with + | Mty_signature _ | Mty_ident _ -> () + | Mty_functor _ | Mty_alias _ -> + raise(Error(me.pmod_loc, env, Invalid_open me))); let md = { md_type = tme.mod_type; md_loc = me.pmod_loc; @@ -144,12 +145,11 @@ let type_open_ ?used_slot ?toplevel ovf env loc me = let newenv = Env.enter_module_declaration ident md env in let root = Pident ident in match Env.open_signature ~loc ?used_slot ?toplevel ovf root newenv with - | None -> assert false + | None -> assert false (* not possible to open a Mty_functor *) | Some opened_env -> Some (ident, md, newenv), tme, opened_env - end let type_open ?toplevel env sod = - let (md, tme, newenv) = + let (inserted_md, tme, open_env) = Builtin_attributes.warning_scope sod.popen_attributes (fun () -> type_open_ ?toplevel sod.popen_override env sod.popen_loc @@ -164,7 +164,7 @@ let type_open ?toplevel env sod = open_loc = sod.popen_loc; } in - md, newenv, od + inserted_md, open_env, od (* Record a module type *) let rm node = @@ -728,13 +728,14 @@ let simplify_signature sg = let remove_inserted_modtype mty = - let remove = - List.filter ( - function - | Sig_module({Ident.name}, _, _) when String.contains name '#' -> false - | _ -> true) in let rec aux = function - | Mty_signature sg -> Mty_signature (remove sg) + | Mty_signature sg -> + let sg = + List.filter ( + function + | Sig_module({Ident.name}, _, _) when open_generated name -> false + | _ -> true) sg in + Mty_signature sg | Mty_functor (id, mty_arg, mty_res) -> Mty_functor (id, (match mty_arg with @@ -922,13 +923,13 @@ and transl_signature env sg = sg :: rem, final_env | Psig_open sod -> begin - let (id, newenv, od) = type_open env sod in - let (trem, rem, final_env) = transl_sig newenv srem in + let (id, open_env, od) = type_open env sod in + let (trem, rem, final_env) = transl_sig open_env srem in match id with | None -> mksig (Tsig_open od) env loc :: trem, rem, final_env | Some (id, _md, _env) -> let s_rem = Mty_signature rem in - match Mtype.nondep_supertype newenv id s_rem with + match Mtype.nondep_supertype open_env id s_rem with | Mty_signature rem' -> mksig (Tsig_open od) env loc :: trem, rem', final_env | exception Not_found -> @@ -1667,32 +1668,32 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = mkstr (Tstr_modtype mtd) newenv loc :: str_rem, sg :: sig_rem, final_env | Pstr_open sod -> begin - let (md, newenv, od) = type_open ~toplevel env sod in - let str_rem, sig_rem, final_env = type_struct newenv srem in - match md with - | None -> mkstr (Tstr_open od) newenv loc :: str_rem, + let (inserted_md, open_env, od) = type_open ~toplevel env sod in + let str_rem, sig_rem, final_env = type_struct open_env srem in + match inserted_md with + | None -> mkstr (Tstr_open od) open_env loc :: str_rem, sig_rem, final_env - | Some (id, md, menv) -> + | Some (id, md, md_env) -> let tm = Tstr_module {mb_id=id; mb_name={txt=Ident.name id; loc=Location.none}; mb_expr = od.open_expr; mb_attributes=od.open_expr.mod_attributes; mb_loc=od.open_expr.mod_loc} in - let tm_str = { str_desc = tm; str_loc = loc; str_env = env } in - let open_str = mkstr (Tstr_open od) menv loc in + let tm_str = { str_desc = tm; str_loc = loc; str_env = md_env } in + let open_str = mkstr (Tstr_open od) open_env loc in let md_sig = Sig_module (id, {md_type=md.Types.md_type; md_loc=loc; md_attributes = []}, Trec_not) in if not (in_nested_struct ()) then let s_rem = Mty_signature sig_rem in - match Mtype.nondep_supertype newenv id s_rem with + match Mtype.nondep_supertype open_env id s_rem with | Mty_signature sg -> tm_str :: open_str :: str_rem, md_sig :: sg, final_env | exception Not_found -> raise (Error(loc, env, Cannot_eliminate_anon_module(id, sig_rem))) - | _ -> assert false + | Mty_ident _ | Mty_functor _ | Mty_alias _ -> assert false else tm_str :: open_str :: str_rem, md_sig :: sig_rem, final_env end @@ -1779,48 +1780,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = Builtin_attributes.warning_attribute x; let str_rem, sig_rem, final_env = type_struct env srem in mkstr (Tstr_attribute x) env loc :: str_rem, sig_rem, final_env - in - (* - let rec type_struct env sstr = - Ctype.init_def(Ident.current_time()); - match sstr with - | [] -> ([], [], [], env) - | pstr :: srem -> begin - let previous_saved_types = Cmt_format.get_saved_types () in - let desc, sg, new_env = type_str_item env srem pstr in - let str = { str_desc = desc; str_loc = pstr.pstr_loc; str_env = env } in - Cmt_format.set_saved_types (Cmt_format.Partial_structure_item str - :: previous_saved_types); - let (str_rem, sig_rem, fsig_rem, final_env) = type_struct new_env srem in - match extract_open_struct desc with - | Some (tm, md, id, md_env) -> begin - let loc = pstr.pstr_loc in - let tm_str = {str_desc = tm; str_loc = loc; - str_env = env} in - let open_str = {str with str_env = md_env} in - let md_sig = - Sig_module (id, {md_type=md.Types.md_type; md_loc=loc; - md_attributes = []}, Trec_not) in - if not (in_nested_struct ()) then begin - let fs_rem = Mty_signature fsig_rem in begin - match Mtype.nondep_supertype new_env id fs_rem with - | Mty_signature sg -> - (tm_str :: open_str :: str_rem, sg, - md_sig :: sg, final_env) - | exception Not_found -> - raise(Error(pstr.pstr_loc, env, - Cannot_eliminate_anon_module(id, fsig_rem))) - | _ -> assert false - end - end else - (tm_str :: open_str :: str_rem, sig_rem, - md_sig :: fsig_rem, final_env) - end - | None -> - (str :: str_rem, sg @ sig_rem, sg @ fsig_rem, final_env) - end in - *) if !Clflags.annotations then (* moved to genannot *) List.iter (function {pstr_loc = l} -> Stypes.record_phrase l) sstr; @@ -1838,7 +1798,8 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = let type_toplevel_phrase env s = Env.reset_required_globals (); let (str, sg, env) = - type_structure ~toplevel:true false None env s Location.none in + Misc.protect_refs [R(open_struct_level, 0)] (fun () -> + type_structure ~toplevel:true false None env s Location.none) in let (str, _coerce) = ImplementationHooks.apply_hooks { Misc.sourcefile = "//toplevel//" } (str, Tcoerce_none) in @@ -1958,7 +1919,7 @@ let simplify_signature sg = if StringSet.mem name val_names then k else (component :: sg, StringSet.add name val_names) | Sig_module({Ident.name}, _, _) :: sg - when String.contains name '#' -> aux sg + when open_generated name -> aux sg | component :: sg -> let (sg, val_names) = aux sg in (component :: sg, val_names) @@ -1967,70 +1928,72 @@ let simplify_signature sg = sg let type_implementation sourcefile outputprefix modulename initial_env ast = - Cmt_format.clear (); - try - Typecore.reset_delayed_checks (); - Env.reset_required_globals (); - if !Clflags.print_types then (* #7656 *) - Warnings.parse_options false "-32-34-37-38-60"; - let (str, sg, finalenv) = - type_structure initial_env ast (Location.in_file sourcefile) in - let simple_sg = simplify_signature sg in - if !Clflags.print_types then begin - Typecore.force_delayed_checks (); - Printtyp.wrap_printing_env initial_env - (fun () -> fprintf std_formatter "%a@." Printtyp.signature simple_sg); - (str, Tcoerce_none) (* result is ignored by Compile.implementation *) - end else begin - let sourceintf = - Filename.remove_extension sourcefile ^ !Config.interface_suffix in - if Sys.file_exists sourceintf then begin - let intf_file = - try - find_in_path_uncap !Config.load_path (modulename ^ ".cmi") - with Not_found -> - raise(Error(Location.in_file sourcefile, Env.empty, - Interface_not_compiled sourceintf)) in - let dclsig = Env.read_signature modulename intf_file in - let coercion = - Includemod.compunit initial_env sourcefile sg intf_file dclsig in + Misc.protect_refs [R(open_struct_level, 0)] (fun () -> + Cmt_format.clear (); + try + Typecore.reset_delayed_checks (); + Env.reset_required_globals (); + if !Clflags.print_types then (* #7656 *) + Warnings.parse_options false "-32-34-37-38-60"; + let (str, sg, finalenv) = + type_structure initial_env ast (Location.in_file sourcefile) in + let simple_sg = simplify_signature sg in + if !Clflags.print_types then begin Typecore.force_delayed_checks (); - (* It is important to run these checks after the inclusion test above, - so that value declarations which are not used internally but exported - are not reported as being unused. *) - Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename - (Cmt_format.Implementation str) (Some sourcefile) initial_env None; - (str, coercion) + Printtyp.wrap_printing_env initial_env + (fun () -> fprintf std_formatter "%a@." Printtyp.signature simple_sg); + (str, Tcoerce_none) (* result is ignored by Compile.implementation *) end else begin - let coercion = - Includemod.compunit initial_env sourcefile sg - "(inferred signature)" simple_sg in - check_nongen_schemes finalenv simple_sg; - normalize_signature finalenv simple_sg; - Typecore.force_delayed_checks (); - (* See comment above. Here the target signature contains all - the value being exported. We can still capture unused - declarations like "let x = true;; let x = 1;;", because in this - case, the inferred signature contains only the last declaration. *) - if not !Clflags.dont_write_files then begin - let deprecated = Builtin_attributes.deprecated_of_str ast in - let cmi = - Env.save_signature ~deprecated - simple_sg modulename (outputprefix ^ ".cmi") - in - Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename - (Cmt_format.Implementation str) - (Some sourcefile) initial_env (Some cmi); - end; - (str, coercion) - end - end - with e -> - Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename - (Cmt_format.Partial_implementation - (Array.of_list (Cmt_format.get_saved_types ()))) - (Some sourcefile) initial_env None; - raise e + let sourceintf = + Filename.remove_extension sourcefile ^ !Config.interface_suffix in + if Sys.file_exists sourceintf then begin + let intf_file = + try + find_in_path_uncap !Config.load_path (modulename ^ ".cmi") + with Not_found -> + raise(Error(Location.in_file sourcefile, Env.empty, + Interface_not_compiled sourceintf)) in + let dclsig = Env.read_signature modulename intf_file in + let coercion = + Includemod.compunit initial_env sourcefile sg intf_file dclsig in + Typecore.force_delayed_checks (); + (* It is important to run these checks after the inclusion test above, + so that value declarations which are not used internally but exported + are not reported as being unused. *) + Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename + (Cmt_format.Implementation str) (Some sourcefile) initial_env None; + (str, coercion) + end else begin + let coercion = + Includemod.compunit initial_env sourcefile sg + "(inferred signature)" simple_sg in + check_nongen_schemes finalenv simple_sg; + normalize_signature finalenv simple_sg; + Typecore.force_delayed_checks (); + (* See comment above. Here the target signature contains all + the value being exported. We can still capture unused + declarations like "let x = true;; let x = 1;;", because in this + case, the inferred signature contains only the last declaration. *) + if not !Clflags.dont_write_files then begin + let deprecated = Builtin_attributes.deprecated_of_str ast in + let cmi = + Env.save_signature ~deprecated + simple_sg modulename (outputprefix ^ ".cmi") + in + Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename + (Cmt_format.Implementation str) + (Some sourcefile) initial_env (Some cmi); + end; + (str, coercion) + end + end + with e -> + Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename + (Cmt_format.Partial_implementation + (Array.of_list (Cmt_format.get_saved_types ()))) + (Some sourcefile) initial_env None; + raise e + ) let type_implementation sourcefile outputprefix modulename initial_env ast = ImplementationHooks.apply_hooks { Misc.sourcefile } From d52c17137f69d910b5f8fde58d846eed9ceb108e Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Sat, 20 Jan 2018 19:01:40 -0800 Subject: [PATCH 13/39] Add Alain and Florian as reviewers. --- Changes | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Changes b/Changes index 0d60919bb684..d225fdbe3991 100644 --- a/Changes +++ b/Changes @@ -11,7 +11,7 @@ Working version Scherer) - GPR#1506: Extending `open` to accept arbitrary module expression - (Runhang Li, review by Jeremy Yallop) + (Runhang Li, review by Alain Frisch, Florian Angeletti, Jeremy Yallop) ### Type system: From fc996472f05fc295cd047d12d40c6ec4194c7099 Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Mon, 29 Jan 2018 23:12:40 -0800 Subject: [PATCH 14/39] save progress --- parsing/ast_helper.mli | 6 +++--- parsing/parser.mly | 35 +++++++++++++++++++---------------- parsing/parsetree.mli | 6 +++--- parsing/pprintast.ml | 12 ++++++------ parsing/printast.ml | 6 +++--- 5 files changed, 34 insertions(+), 31 deletions(-) diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli index e26af721ba8f..d9978be15fe9 100644 --- a/parsing/ast_helper.mli +++ b/parsing/ast_helper.mli @@ -168,7 +168,7 @@ module Exp: val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression - val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid + val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> module_expr -> expression -> expression val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression @@ -352,7 +352,7 @@ module Cty: val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> class_type -> class_type val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type - val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> class_type + val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> module_expr -> class_type -> class_type end @@ -392,7 +392,7 @@ module Cl: val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type -> class_expr val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr - val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> class_expr + val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> module_expr -> class_expr -> class_expr end diff --git a/parsing/parser.mly b/parsing/parser.mly index ef6e01201a05..d5bef9e9807e 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -49,6 +49,9 @@ let mkoperator name pos = let mkpatvar name pos = Pat.mk ~loc:(rhs_loc pos) (Ppat_var (mkrhs name pos)) +let mkmodexpr name pos = + Mod.ident ~loc:(rhs_loc pos) (mkrhs name pos) + (* Ghost expressions and patterns: expressions and patterns that do not appear explicitly in the @@ -1036,8 +1039,8 @@ class_expr: { mkclass(Pcl_apply($1, List.rev $2)) } | let_bindings IN class_expr { class_of_let_bindings $1 $3 } - | LET OPEN override_flag attributes mod_longident IN class_expr - { wrap_class_attrs (mkclass(Pcl_open($3, mkrhs $5 5, $7))) $4 } + | LET OPEN override_flag attributes module_expr IN class_expr + { wrap_class_attrs (mkclass(Pcl_open($3, $5, $7))) $4 } | class_expr attribute { Cl.attr $1 $2 } | extension @@ -1170,8 +1173,8 @@ class_signature: { Cty.attr $1 $2 } | extension { mkcty(Pcty_extension $1) } - | LET OPEN override_flag attributes mod_longident IN class_signature - { wrap_class_type_attrs (mkcty(Pcty_open($3, mkrhs $5 5, $7))) $4 } + | LET OPEN override_flag attributes module_expr IN class_signature + { wrap_class_type_attrs (mkcty(Pcty_open($3, $5, $7))) $4 } ; class_sig_body: class_self_type class_sig_fields @@ -1326,8 +1329,8 @@ expr: { mkexp_attrs (Pexp_letmodule(mkrhs $4 4, $5, $7)) $3 } | LET EXCEPTION ext_attributes let_exception_declaration IN seq_expr { mkexp_attrs (Pexp_letexception($4, $6)) $3 } - | LET OPEN override_flag ext_attributes mod_longident IN seq_expr - { mkexp_attrs (Pexp_open($3, mkrhs $5 5, $7)) $4 } + | LET OPEN override_flag ext_attributes module_expr IN seq_expr + { mkexp_attrs (Pexp_open($3, $5, $7)) $4 } | FUNCTION ext_attributes opt_bar match_cases { mkexp_attrs (Pexp_function(List.rev $4)) $2 } | FUN ext_attributes labeled_simple_pattern fun_def @@ -1470,9 +1473,9 @@ simple_expr: | simple_expr DOT label_longident { mkexp(Pexp_field($1, mkrhs $3 3)) } | mod_longident DOT LPAREN seq_expr RPAREN - { mkexp(Pexp_open(Fresh, mkrhs $1 1, $4)) } + { mkexp(Pexp_open(Fresh, mkmodexpr $1 1, $4)) } | mod_longident DOT LPAREN RPAREN - { mkexp(Pexp_open(Fresh, mkrhs $1 1, + { mkexp(Pexp_open(Fresh, mkmodexpr $1 1, mkexp(Pexp_construct(mkrhs (Lident "()") 1, None)))) } | mod_longident DOT LPAREN seq_expr error { unclosed "(" 3 ")" 5 } @@ -1527,7 +1530,7 @@ simple_expr: | mod_longident DOT LBRACE record_expr RBRACE { let (exten, fields) = $4 in let rec_exp = mkexp(Pexp_record(fields, exten)) in - mkexp(Pexp_open(Fresh, mkrhs $1 1, rec_exp)) } + mkexp(Pexp_open(Fresh, mkmodexpr $1 1, rec_exp)) } | mod_longident DOT LBRACE record_expr error { unclosed "{" 3 "}" 5 } | LBRACKETBAR expr_semi_list opt_semi BARRBRACKET @@ -1537,9 +1540,9 @@ simple_expr: | LBRACKETBAR BARRBRACKET { mkexp (Pexp_array []) } | mod_longident DOT LBRACKETBAR expr_semi_list opt_semi BARRBRACKET - { mkexp(Pexp_open(Fresh, mkrhs $1 1, mkexp(Pexp_array(List.rev $4)))) } + { mkexp(Pexp_open(Fresh, mkmodexpr $1 1, mkexp(Pexp_array(List.rev $4)))) } | mod_longident DOT LBRACKETBAR BARRBRACKET - { mkexp(Pexp_open(Fresh, mkrhs $1 1, mkexp(Pexp_array []))) } + { mkexp(Pexp_open(Fresh, mkmodexpr $1 1, mkexp(Pexp_array []))) } | mod_longident DOT LBRACKETBAR expr_semi_list opt_semi error { unclosed "[|" 3 "|]" 6 } | LBRACKET expr_semi_list opt_semi RBRACKET @@ -1548,9 +1551,9 @@ simple_expr: { unclosed "[" 1 "]" 4 } | mod_longident DOT LBRACKET expr_semi_list opt_semi RBRACKET { let list_exp = reloc_exp (mktailexp (rhs_loc 6) (List.rev $4)) in - mkexp(Pexp_open(Fresh, mkrhs $1 1, list_exp)) } + mkexp(Pexp_open(Fresh, mkmodexpr $1 1, list_exp)) } | mod_longident DOT LBRACKET RBRACKET - { mkexp(Pexp_open(Fresh, mkrhs $1 1, + { mkexp(Pexp_open(Fresh, mkmodexpr $1 1, mkexp(Pexp_construct(mkrhs (Lident "[]") 1, None)))) } | mod_longident DOT LBRACKET expr_semi_list opt_semi error { unclosed "[" 3 "]" 6 } @@ -1567,9 +1570,9 @@ simple_expr: | LBRACELESS GREATERRBRACE { mkexp (Pexp_override [])} | mod_longident DOT LBRACELESS field_expr_list GREATERRBRACE - { mkexp(Pexp_open(Fresh, mkrhs $1 1, mkexp (Pexp_override $4)))} + { mkexp(Pexp_open(Fresh, mkmodexpr $1 1, mkexp (Pexp_override $4)))} | mod_longident DOT LBRACELESS GREATERRBRACE - { mkexp(Pexp_open(Fresh, mkrhs $1 1, mkexp (Pexp_override [])))} + { mkexp(Pexp_open(Fresh, mkmodexpr $1 1, mkexp (Pexp_override [])))} | mod_longident DOT LBRACELESS field_expr_list error { unclosed "{<" 3 ">}" 5 } | simple_expr HASH label @@ -1586,7 +1589,7 @@ simple_expr: { unclosed "(" 1 ")" 6 } | mod_longident DOT LPAREN MODULE ext_attributes module_expr COLON package_type RPAREN - { mkexp(Pexp_open(Fresh, mkrhs $1 1, + { mkexp(Pexp_open(Fresh, mkmodexpr $1 1, mkexp_attrs (Pexp_constraint (ghexp (Pexp_pack $6), ghtyp (Ptyp_package $8))) $5 )) } diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index e01e5e254553..36c6406b50de 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -346,7 +346,7 @@ and expression_desc = (module ME : S) is represented as Pexp_constraint(Pexp_pack, Ptyp_package S) *) - | Pexp_open of override_flag * Longident.t loc * expression + | Pexp_open of override_flag * module_expr * expression (* M.(E) let open M in E let! open M in E *) @@ -505,7 +505,7 @@ and class_type_desc = *) | Pcty_extension of extension (* [%id] *) - | Pcty_open of override_flag * Longident.t loc * class_type + | Pcty_open of override_flag * module_expr * class_type (* let open M in CT *) and class_signature = @@ -597,7 +597,7 @@ and class_expr_desc = (* (CE : CT) *) | Pcl_extension of extension (* [%id] *) - | Pcl_open of override_flag * Longident.t loc * class_expr + | Pcl_open of override_flag * module_expr * class_expr (* let open M in CE *) diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index 59a9a02311f9..4e945838f56f 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -666,8 +666,8 @@ and expression ctxt f x = | Pexp_poly (e, Some ct) -> pp f "@[(!poly!@ %a@ : %a)@]" (simple_expr ctxt) e (core_type ctxt) ct - | Pexp_open (ovf, lid, e) -> - pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid + | Pexp_open (ovf, m, e) -> + pp f "@[<2>let open%s %a in@;%a@]" (override ovf) (module_expr ctxt) m (expression ctxt) e | Pexp_variant (l,Some eo) -> pp f "@[<2>`%s@;%a@]" l (simple_expr ctxt) eo @@ -830,8 +830,8 @@ and class_type ctxt f x = | Pcty_extension e -> extension ctxt f e; attributes ctxt f x.pcty_attributes - | Pcty_open (ovf, lid, e) -> - pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid + | Pcty_open (ovf, m, e) -> + pp f "@[<2>let open%s %a in@;%a@]" (override ovf) (module_expr ctxt) m (class_type ctxt) e (* [class type a = object end] *) @@ -949,8 +949,8 @@ and class_expr ctxt f x = (class_expr ctxt) ce (class_type ctxt) ct | Pcl_extension e -> extension ctxt f e - | Pcl_open (ovf, lid, e) -> - pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid + | Pcl_open (ovf, m, e) -> + pp f "@[<2>let open%s %a in@;%a@]" (override ovf) (module_expr ctxt) m (class_expr ctxt) e and module_type ctxt f x = diff --git a/parsing/printast.ml b/parsing/printast.ml index 6e43d16c4bdb..5966afdf4c5a 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -372,7 +372,7 @@ and expression i ppf x = module_expr i ppf me | Pexp_open (ovf, m, e) -> line i ppf "Pexp_open %a \"%a\"\n" fmt_override_flag ovf - fmt_longident_loc m; + (module_expr i) m; expression i ppf e | Pexp_extension (s, arg) -> line i ppf "Pexp_extension \"%s\"\n" s.txt; @@ -487,7 +487,7 @@ and class_type i ppf x = payload i ppf arg | Pcty_open (ovf, m, e) -> line i ppf "Pcty_open %a \"%a\"\n" fmt_override_flag ovf - fmt_longident_loc m; + (module_expr i) m; class_type i ppf e and class_signature i ppf cs = @@ -578,7 +578,7 @@ and class_expr i ppf x = payload i ppf arg | Pcl_open (ovf, m, e) -> line i ppf "Pcl_open %a \"%a\"\n" fmt_override_flag ovf - fmt_longident_loc m; + (module_expr i) m; class_expr i ppf e and class_structure i ppf { pcstr_self = p; pcstr_fields = l } = From a2bbf15d726b70032afbb6517897e17c1faa21ae Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Tue, 20 Feb 2018 21:39:53 -0800 Subject: [PATCH 15/39] save --- parsing/ast_invariants.ml | 3 +- parsing/ast_iterator.ml | 12 +++---- parsing/ast_mapper.ml | 12 +++---- parsing/depend.ml | 70 ++++++++++++++++++++++----------------- typing/printtyped.ml | 17 +++++----- typing/tast_mapper.ml | 19 +++++++---- typing/typeclass.ml | 18 +++++----- typing/typecore.ml | 16 +++++---- typing/typedtree.ml | 7 ++-- typing/typedtree.mli | 7 ++-- typing/typedtreeIter.ml | 10 +++--- typing/typedtreeMap.ml | 13 +++++--- typing/untypeast.ml | 12 +++---- 13 files changed, 121 insertions(+), 95 deletions(-) diff --git a/parsing/ast_invariants.ml b/parsing/ast_invariants.ml index 536710cb14ea..96680f09e4a3 100644 --- a/parsing/ast_invariants.ml +++ b/parsing/ast_invariants.ml @@ -89,8 +89,7 @@ let iterator = | Pexp_construct (id, _) | Pexp_field (_, id) | Pexp_setfield (_, id, _) - | Pexp_new id - | Pexp_open (_, id, _) -> simple_longident id + | Pexp_new id -> simple_longident id | Pexp_record (fields, _) -> List.iter (fun (id, _) -> simple_longident id) fields | _ -> () diff --git a/parsing/ast_iterator.ml b/parsing/ast_iterator.ml index d9eafdf271c9..90e37764fac2 100755 --- a/parsing/ast_iterator.ml +++ b/parsing/ast_iterator.ml @@ -186,8 +186,8 @@ module CT = struct | Pcty_arrow (_lab, t, ct) -> sub.typ sub t; sub.class_type sub ct | Pcty_extension x -> sub.extension sub x - | Pcty_open (_ovf, lid, e) -> - iter_loc sub lid; sub.class_type sub e + | Pcty_open (_ovf, me, e) -> + sub.module_expr sub me; sub.class_type sub e let iter_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} = @@ -372,8 +372,8 @@ module E = struct | Pexp_object cls -> sub.class_structure sub cls | Pexp_newtype (_s, e) -> sub.expr sub e | Pexp_pack me -> sub.module_expr sub me - | Pexp_open (_ovf, lid, e) -> - iter_loc sub lid; sub.expr sub e + | Pexp_open (_ovf, me, e) -> + sub.module_expr sub me; sub.expr sub e | Pexp_extension x -> sub.extension sub x | Pexp_unreachable -> () end @@ -434,8 +434,8 @@ module CE = struct | Pcl_constraint (ce, ct) -> sub.class_expr sub ce; sub.class_type sub ct | Pcl_extension x -> sub.extension sub x - | Pcl_open (_ovf, lid, e) -> - iter_loc sub lid; sub.class_expr sub e + | Pcl_open (_ovf, me, e) -> + sub.module_expr sub me; sub.class_expr sub e let iter_kind sub = function | Cfk_concrete (_o, e) -> sub.expr sub e diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index 7053bd2b6995..4d70a3c6fd92 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -195,8 +195,8 @@ module CT = struct | Pcty_arrow (lab, t, ct) -> arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct) | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pcty_open (ovf, lid, ct) -> - open_ ~loc ~attrs ovf (map_loc sub lid) (sub.class_type sub ct) + | Pcty_open (ovf, me, ct) -> + open_ ~loc ~attrs ovf (sub.module_expr sub me) (sub.class_type sub ct) let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} = @@ -394,8 +394,8 @@ module E = struct | Pexp_newtype (s, e) -> newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e) | 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_open (ovf, me, e) -> + open_ ~loc ~attrs ovf (sub.module_expr sub me) (sub.expr sub e) | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x) | Pexp_unreachable -> unreachable ~loc ~attrs () end @@ -458,8 +458,8 @@ module CE = struct | Pcl_constraint (ce, ct) -> constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct) | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pcl_open (ovf, lid, ce) -> - open_ ~loc ~attrs ovf (map_loc sub lid) (sub.class_expr sub ce) + | Pcl_open (ovf, me, ce) -> + open_ ~loc ~attrs ovf (sub.module_expr sub me) (sub.class_expr sub ce) let map_kind sub = function | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e) diff --git a/parsing/depend.ml b/parsing/depend.ml index d85ccee1df33..0cca08c5f8d1 100644 --- a/parsing/depend.ml +++ b/parsing/depend.ml @@ -160,32 +160,6 @@ let add_type_extension bv te = add bv te.ptyext_path; List.iter (add_extension_constructor bv) te.ptyext_constructors -let rec add_class_type bv cty = - match cty.pcty_desc with - Pcty_constr(l, tyl) -> - add bv l; List.iter (add_type bv) tyl - | Pcty_signature { pcsig_self = ty; pcsig_fields = fieldl } -> - add_type bv ty; - List.iter (add_class_type_field bv) fieldl - | Pcty_arrow(_, ty1, cty2) -> - add_type bv ty1; add_class_type bv cty2 - | Pcty_extension e -> handle_extension e - | Pcty_open (_ovf, m, e) -> - let bv = open_module bv m.txt in add_class_type bv e - -and add_class_type_field bv pctf = - match pctf.pctf_desc with - Pctf_inherit cty -> add_class_type bv cty - | Pctf_val(_, _, _, ty) -> add_type bv ty - | Pctf_method(_, _, _, ty) -> add_type bv ty - | Pctf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2 - | Pctf_attribute _ -> () - | Pctf_extension e -> handle_extension e - -let add_class_description bv infos = - add_class_type bv infos.pci_expr - -let add_class_type_declaration = add_class_description let pattern_bv = ref StringMap.empty @@ -268,7 +242,10 @@ let rec add_expr bv exp = | Pexp_newtype (_, e) -> add_expr bv e | Pexp_pack m -> add_module_expr bv m | Pexp_open (_ovf, m, e) -> - let bv = open_module bv m.txt in add_expr bv e + let Node(s, m') = add_module_binding bv m in + add_names s; + let bv = StringMap.fold StringMap.add m' bv in + add_expr bv e | Pexp_extension (({ txt = ("ocaml.extension_constructor"| "extension_constructor"); _ }, PStr [item]) as e) -> @@ -383,7 +360,7 @@ and add_sig_item (bv, m) item = | Psig_class cdl -> List.iter (add_class_description bv) cdl; (bv, m) | Psig_class_type cdtl -> - List.iter (add_class_type_declaration bv) cdtl; (bv, m) + List.iter (add_class_type_declaration () bv) cdtl; (bv, m) | Psig_attribute _ -> (bv, m) | Psig_extension (e, _) -> handle_extension e; @@ -412,6 +389,36 @@ and add_module_expr bv modl = | Pmod_extension e -> handle_extension e +and add_class_type bv cty = + match cty.pcty_desc with + Pcty_constr(l, tyl) -> + add bv l; List.iter (add_type bv) tyl + | Pcty_signature { pcsig_self = ty; pcsig_fields = fieldl } -> + add_type bv ty; + List.iter (add_class_type_field bv) fieldl + | Pcty_arrow(_, ty1, cty2) -> + add_type bv ty1; add_class_type bv cty2 + | Pcty_extension e -> handle_extension e + | Pcty_open (_ovf, m, e) -> + let Node(s, m') = add_module_binding bv m in + add_names s; + let bv = StringMap.fold StringMap.add m' bv in + add_class_type bv e + +and add_class_type_field bv pctf = + match pctf.pctf_desc with + Pctf_inherit cty -> add_class_type bv cty + | Pctf_val(_, _, _, ty) -> add_type bv ty + | Pctf_method(_, _, _, ty) -> add_type bv ty + | Pctf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2 + | Pctf_attribute _ -> () + | Pctf_extension e -> handle_extension e + +and add_class_description bv infos = + add_class_type bv infos.pci_expr + +and add_class_type_declaration () = add_class_description + and add_structure bv item_list = let (bv, m) = add_structure_binding bv item_list in add_names (collect_free (make_node m)); @@ -462,7 +469,7 @@ and add_struct_item (bv, m) item : _ StringMap.t * _ StringMap.t = | Pstr_class cdl -> List.iter (add_class_declaration bv) cdl; (bv, m) | Pstr_class_type cdtl -> - List.iter (add_class_type_declaration bv) cdtl; (bv, m) + List.iter (add_class_type_declaration () bv) cdtl; (bv, m) | Pstr_include incl -> let Node (s, m') as n = add_module_binding bv incl.pincl_mod in if !Clflags.transparent_modules then @@ -508,7 +515,10 @@ and add_class_expr bv ce = add_class_expr bv ce; add_class_type bv ct | Pcl_extension e -> handle_extension e | Pcl_open (_ovf, m, e) -> - let bv = open_module bv m.txt in add_class_expr bv e + let Node(s, m') = add_module_binding bv m in + add_names s; + let bv = StringMap.fold StringMap.add m' bv in + add_class_expr bv e and add_class_field bv pcf = match pcf.pcf_desc with diff --git a/typing/printtyped.ml b/typing/printtyped.ml index 402da194c2f8..caf412abb0ad 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -279,9 +279,10 @@ and expression_extra i ppf x attrs = attributes i ppf attrs; option i core_type ppf cto1; core_type i ppf cto2; - | Texp_open (ovf, lid, _) -> - line i ppf "Texp_open %a \"%a\"\n" fmt_override_flag ovf fmt_longident lid; + | Texp_open od -> + line i ppf "Texp_open %a\n" fmt_override_flag od.open_override; attributes i ppf attrs; + module_expr i ppf od.open_expr | Texp_poly cto -> line i ppf "Texp_poly\n"; attributes i ppf attrs; @@ -493,9 +494,9 @@ and class_type i ppf x = arg_label i ppf l; core_type i ppf co; class_type i ppf cl; - | Tcty_open (ovf, id, _, e) -> - line i ppf "Tcty_open %a \"%a\"\n" fmt_override_flag ovf - fmt_longident id; + | Tcty_open (od, e) -> + line i ppf "Tcty_open %a\n" fmt_override_flag od.open_override; + module_expr i ppf od.open_expr; class_type i ppf e and class_signature i ppf { csig_self = ct; csig_fields = l } = @@ -578,9 +579,9 @@ and class_expr i ppf x = class_expr i ppf ce; class_type i ppf ct | Tcl_constraint (ce, None, _, _, _) -> class_expr i ppf ce - | Tcl_open (ovf, id, _, e) -> - line i ppf "Tcty_open %a \"%a\"\n" fmt_override_flag ovf - fmt_longident id; + | Tcl_open (od, e) -> + line i ppf "Tcty_open %a \n" fmt_override_flag od.open_override; + module_expr i ppf od.open_expr; class_expr i ppf e and class_structure i ppf { cstr_self = p; cstr_fields = l } = diff --git a/typing/tast_mapper.ml b/typing/tast_mapper.ml index 9175758c2ca9..cc1e1813741b 100644 --- a/typing/tast_mapper.ml +++ b/typing/tast_mapper.ml @@ -218,8 +218,10 @@ let expr sub x = Texp_constraint (sub.typ sub cty) | Texp_coerce (cty1, cty2) -> Texp_coerce (opt (sub.typ sub) cty1, sub.typ sub cty2) - | Texp_open (ovf, loc, env) -> - Texp_open (ovf, loc, sub.env sub env) + | Texp_open od -> + Texp_open {od with + open_expr = sub.module_expr sub od.open_expr; + open_env = sub.env sub od.open_env} | Texp_newtype _ as d -> d | Texp_poly cto -> Texp_poly (opt (sub.typ sub) cto) in @@ -524,8 +526,11 @@ let class_expr sub x = ) | Tcl_ident (path, lid, tyl) -> Tcl_ident (path, lid, List.map (sub.typ sub) tyl) - | Tcl_open (ovf, lid, env, e) -> - Tcl_open (ovf, lid, sub.env sub env, sub.class_expr sub e) + | Tcl_open (od, e) -> + Tcl_open ( + {od with + open_expr = sub.module_expr sub od.open_expr; + open_env = sub.env sub od.open_env}, sub.class_expr sub e) in {x with cl_desc; cl_env} @@ -546,8 +551,10 @@ let class_type sub x = sub.typ sub ct, sub.class_type sub cl ) - | Tcty_open (ovf, lid, env, e) -> - Tcty_open (ovf, lid, sub.env sub env, sub.class_type sub e) + | Tcty_open (od, e) -> + Tcty_open ({od with + open_expr = sub.module_expr sub od.open_expr; + open_env = sub.env sub od.open_env}, sub.class_type sub e) in {x with cltyp_desc; cltyp_env} diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 64044ff7bd70..378d95a13676 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -553,12 +553,13 @@ and class_type_aux env scty = let typ = Cty_arrow (l, ty, clty.cltyp_type) in cltyp (Tcty_arrow (l, cty, clty)) typ - | Pcty_open (ovf, lid, e) -> - let me = {pmod_desc=Pmod_ident lid; pmod_loc=lid.loc; - pmod_attributes=[]} in - let (_tme, newenv) = !Typecore.type_open ovf env scty.pcty_loc me in + | Pcty_open (ovf, me, e) -> + let (tme, newenv) = !Typecore.type_open ovf env scty.pcty_loc me in let clty = class_type newenv e in - cltyp (Tcty_open (ovf, lid, newenv, clty)) clty.cltyp_type + let od = { + open_expr=tme; open_override=ovf; open_loc=scty.pcty_loc; + open_env=newenv; open_attributes=scty.pcty_attributes} in + cltyp (Tcty_open (od, clty)) clty.cltyp_type | Pcty_extension ext -> raise (Error_forward (Builtin_attributes.error_of_extension ext)) @@ -1226,13 +1227,12 @@ and class_expr_aux cl_num val_env met_env scl = cl_env = val_env; cl_attributes = scl.pcl_attributes; } - | Pcl_open (ovf, lid, e) -> + | Pcl_open (ovf, me, e) -> let used_slot = ref false in - let me = {pmod_desc=Pmod_ident lid; pmod_loc=lid.loc; pmod_attributes=[]} in let (_, new_val_env) = !Typecore.type_open ~used_slot ovf val_env scl.pcl_loc me in - let (_, new_met_env) = !Typecore.type_open ~used_slot ovf met_env scl.pcl_loc me in + let (tme, new_met_env) = !Typecore.type_open ~used_slot ovf met_env scl.pcl_loc me in let cl = class_expr cl_num new_val_env new_met_env e in - rc {cl_desc = Tcl_open (ovf, lid, new_val_env, cl); + rc {cl_desc = Tcl_open (ovf, tme, new_val_env, cl); cl_loc = scl.pcl_loc; cl_type = cl.cl_type; cl_env = val_env; diff --git a/typing/typecore.ml b/typing/typecore.ml index e32ed0945f3f..aeb794c1fc69 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -2244,7 +2244,8 @@ struct Use.(inspect (join ty (class_expr env ce))) | Tcl_constraint (ce, _, _, _, _) -> class_expr env ce - | Tcl_open (_, _, _, ce) -> + | Tcl_open (_, ce) -> + (* TODO DEP *) class_expr env ce and case : Env.env -> Typedtree.case -> scrutinee:Use.t -> Use.t = fun env { Typedtree.c_lhs; c_guard; c_rhs } ~scrutinee:ty -> @@ -2344,7 +2345,7 @@ struct Use.join ty (class_expr env ce) | Tcl_constraint (ce, _, _, _, _) -> class_expr env ce - | Tcl_open (_, _, _, ce) -> + | Tcl_open (_, ce) -> class_expr env ce in match Use.unguarded (class_expr (build_unguarded_env idlist) ce) with @@ -3723,13 +3724,14 @@ and type_expect_ exp_type = newty (Tpackage (p, nl, tl')); exp_attributes = sexp.pexp_attributes; exp_env = env } - | Pexp_open (ovf, lid, e) -> - let me = {pmod_desc=Pmod_ident lid; pmod_loc=lid.loc; - pmod_attributes=[]} in - let (_tme, newenv) = !type_open ovf env sexp.pexp_loc me in + | Pexp_open (ovf, me, e) -> + let (tme, newenv) = !type_open ovf env sexp.pexp_loc me in let exp = type_expect newenv e ty_expected_explained in + let od = { open_expr=tme; open_override=ovf; + open_loc=loc; open_env=newenv; (*TODO*) + open_attributes=sexp.pexp_attributes } in { exp with - exp_extra = (Texp_open (ovf, lid, newenv), loc, + exp_extra = (Texp_open od, loc, sexp.pexp_attributes) :: exp.exp_extra; } diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 541bea93f648..f624ca198280 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -69,7 +69,7 @@ and expression = and exp_extra = | Texp_constraint of core_type | Texp_coerce of core_type option * core_type - | Texp_open of override_flag * Longident.t loc * Env.t + | Texp_open of open_description | Texp_poly of core_type option | Texp_newtype of string @@ -153,7 +153,7 @@ and class_expr_desc = | Tcl_constraint of class_expr * class_type option * string list * string list * Concr.t (* Visible instance variables, methods and concrete methods *) - | Tcl_open of override_flag * Longident.t loc * Env.t * class_expr + | Tcl_open of open_description * class_expr and class_structure = { @@ -334,6 +334,7 @@ and open_description = open_expr: module_expr; open_override: override_flag; open_loc: Location.t; + open_env: Env.t; open_attributes: attribute list; } @@ -482,7 +483,7 @@ and class_type_desc = Tcty_constr of Path.t * Longident.t loc * core_type list | Tcty_signature of class_signature | Tcty_arrow of arg_label * core_type * class_type - | Tcty_open of override_flag * Longident.t loc * Env.t * class_type + | Tcty_open of open_description * class_type and class_signature = { csig_self: core_type; diff --git a/typing/typedtree.mli b/typing/typedtree.mli index 58df8efa019f..cc810e2706cb 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -123,7 +123,7 @@ and exp_extra = (** E :> T [Texp_coerce (None, T)] E : T0 :> T [Texp_coerce (Some T0, T)] *) - | Texp_open of override_flag * Longident.t loc * Env.t + | Texp_open of open_description (** let open[!] M in [Texp_open (!, P, M, env)] where [env] is the environment after opening [P] *) @@ -268,7 +268,7 @@ and class_expr_desc = | Tcl_constraint of class_expr * class_type option * string list * string list * Concr.t (* Visible instance variables, methods and concrete methods *) - | Tcl_open of override_flag * Longident.t loc * Env.t * class_expr + | Tcl_open of open_description * class_expr and class_structure = { @@ -454,6 +454,7 @@ and open_description = open_expr: module_expr; open_override: override_flag; open_loc: Location.t; + open_env: Env.t; open_attributes: attribute list; } @@ -604,7 +605,7 @@ and class_type_desc = Tcty_constr of Path.t * Longident.t loc * core_type list | Tcty_signature of class_signature | Tcty_arrow of arg_label * core_type * class_type - | Tcty_open of override_flag * Longident.t loc * Env.t * class_type + | Tcty_open of open_description * class_type and class_signature = { csig_self : core_type; diff --git a/typing/typedtreeIter.ml b/typing/typedtreeIter.ml index be5b071c9522..86563575d4cf 100644 --- a/typing/typedtreeIter.ml +++ b/typing/typedtreeIter.ml @@ -145,7 +145,7 @@ module MakeIterator(Iter : IteratorArgument) : sig | Tstr_module x -> iter_module_binding x | Tstr_recmodule list -> List.iter iter_module_binding list | Tstr_modtype mtd -> iter_module_type_declaration mtd - | Tstr_open _ -> () + | Tstr_open od -> iter_module_expr od.open_expr | Tstr_class list -> List.iter (fun (ci, _) -> iter_class_declaration ci) list | Tstr_class_type list -> @@ -390,7 +390,7 @@ module MakeIterator(Iter : IteratorArgument) : sig List.iter (fun md -> iter_module_type md.md_type) list | Tsig_modtype mtd -> iter_module_type_declaration mtd - | Tsig_open _ -> () + | Tsig_open od -> iter_module_expr od.open_expr | Tsig_include incl -> iter_module_type incl.incl_mod | Tsig_class list -> List.iter iter_class_description list @@ -512,7 +512,8 @@ module MakeIterator(Iter : IteratorArgument) : sig | Tcl_ident (_, _, tyl) -> List.iter iter_core_type tyl - | Tcl_open (_, _, _, e) -> + | Tcl_open (od, e) -> + iter_module_expr od.open_expr; iter_class_expr e end; Iter.leave_class_expr cexpr; @@ -527,7 +528,8 @@ module MakeIterator(Iter : IteratorArgument) : sig | Tcty_arrow (_label, ct, cl) -> iter_core_type ct; iter_class_type cl - | Tcty_open (_, _, _, e) -> + | Tcty_open (od, e) -> + iter_module_expr od.open_expr; iter_class_type e end; Iter.leave_class_type ct; diff --git a/typing/typedtreeMap.ml b/typing/typedtreeMap.ml index f671f39d9d81..b1e549bc26b9 100644 --- a/typing/typedtreeMap.ml +++ b/typing/typedtreeMap.ml @@ -129,7 +129,8 @@ module MakeMap(Map : MapArgument) = struct Tstr_recmodule list | Tstr_modtype mtd -> Tstr_modtype (map_module_type_declaration mtd) - | Tstr_open od -> Tstr_open od + | Tstr_open od -> + Tstr_open {od with open_expr = map_module_expr od.open_expr} | Tstr_class list -> let list = List.map @@ -567,8 +568,10 @@ module MakeMap(Map : MapArgument) = struct | Tcl_ident (id, name, tyl) -> Tcl_ident (id, name, List.map map_core_type tyl) - | Tcl_open (ovf, lid, env, e) -> - Tcl_open (ovf, lid, env, map_class_expr e) + | Tcl_open (od, e) -> + Tcl_open ( + {od with open_expr = map_module_expr od.open_expr}, + map_class_expr e) in Map.leave_class_expr { cexpr with cl_desc = cl_desc } @@ -581,8 +584,8 @@ module MakeMap(Map : MapArgument) = struct Tcty_constr (path, lid, List.map map_core_type list) | Tcty_arrow (label, ct, cl) -> Tcty_arrow (label, map_core_type ct, map_class_type cl) - | Tcty_open (ovf, lid, env, e) -> - Tcty_open (ovf, lid, env, map_class_type e) + | Tcty_open (od, e) -> + Tcty_open ({od with open_expr = od.open_expr}, map_class_type e) in Map.leave_class_type { ct with cltyp_desc = cltyp_desc } diff --git a/typing/untypeast.ml b/typing/untypeast.ml index e242399941cf..4f12df7b7676 100644 --- a/typing/untypeast.ml +++ b/typing/untypeast.ml @@ -329,8 +329,8 @@ let exp_extra sub (extra, loc, attrs) sexp = sub.typ sub cty2) | Texp_constraint cty -> Pexp_constraint (sexp, sub.typ sub cty) - | Texp_open (ovf, lid, _) -> - Pexp_open (ovf, map_loc sub lid, sexp) + | Texp_open od -> + Pexp_open (od.open_override, sub.module_expr sub od.open_expr, sexp) | Texp_poly cto -> Pexp_poly (sexp, map_opt (sub.typ sub) cto) | Texp_newtype s -> Pexp_newtype (mkloc s loc, sexp) in @@ -634,8 +634,8 @@ let class_expr sub cexpr = | Tcl_constraint (cl, Some clty, _vals, _meths, _concrs) -> Pcl_constraint (sub.class_expr sub cl, sub.class_type sub clty) - | Tcl_open (ovf, lid, _env, e) -> - Pcl_open (ovf, lid, sub.class_expr sub e) + | Tcl_open (od, e) -> + Pcl_open (od.open_override, sub.module_expr sub od.open_expr, sub.class_expr sub e) | Tcl_ident _ -> assert false | Tcl_constraint (_, None, _, _, _) -> assert false @@ -651,8 +651,8 @@ let class_type sub ct = Pcty_constr (map_loc sub lid, List.map (sub.typ sub) list) | Tcty_arrow (label, ct, cl) -> Pcty_arrow (label, sub.typ sub ct, sub.class_type sub cl) - | Tcty_open (ovf, lid, _env, e) -> - Pcty_open (ovf, lid, sub.class_type sub e) + | Tcty_open (od, e) -> + Pcty_open (od.open_override, sub.module_expr sub od.open_expr, sub.class_type sub e) in Cty.mk ~loc ~attrs desc From ee9e4330e9c65496cfb078aff15b40a53fc59b01 Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Sat, 10 Mar 2018 14:09:16 -0800 Subject: [PATCH 16/39] work. --- bytecomp/translclass.ml | 8 ++++---- typing/typeclass.ml | 12 ++++++++++-- typing/typemod.ml | 1 + 3 files changed, 15 insertions(+), 6 deletions(-) diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index 92fac3ef2ea4..8b0df170fc39 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -195,7 +195,7 @@ let rec build_object_init cl_table obj params inh_init obj_init cl = build_object_init cl_table obj (vals @ params) inh_init obj_init cl in (inh_init, Translcore.transl_let rec_flag defs obj_init) - | Tcl_open (_, _, _, cl) + | Tcl_open (_, cl) | Tcl_constraint (cl, _, _, _, _) -> build_object_init cl_table obj params inh_init obj_init cl @@ -387,7 +387,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = Lsequence(mkappl (oo_prim "narrow", narrow_args), cl_init)) end - | Tcl_open (_, _, _, cl) -> + | Tcl_open (_, cl) -> build_class_init cla cstr super inh_init cl_init msubst top cl let rec build_class_lets cl = @@ -407,7 +407,7 @@ let rec get_class_meths cl = | Tcl_fun (_, _, _, cl, _) | Tcl_let (_, _, _, cl) | Tcl_apply (cl, _) - | Tcl_open (_, _, _, cl) + | Tcl_open (_, cl) | Tcl_constraint (cl, _, _, _, _) -> get_class_meths cl (* @@ -453,7 +453,7 @@ let rec transl_class_rebind obj_init cl vf = in check_constraint cl.cl_type; (path, obj_init) - | Tcl_open (_, _, _, cl) -> + | Tcl_open (_, cl) -> transl_class_rebind obj_init cl vf let rec transl_class_rebind_0 self obj_init cl vf = diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 378d95a13676..ec3efb576992 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -1231,8 +1231,16 @@ and class_expr_aux cl_num val_env met_env scl = let used_slot = ref false in let (_, new_val_env) = !Typecore.type_open ~used_slot ovf val_env scl.pcl_loc me in let (tme, new_met_env) = !Typecore.type_open ~used_slot ovf met_env scl.pcl_loc me in + (* TODO(objmagic): what env to use here? *) let cl = class_expr cl_num new_val_env new_met_env e in - rc {cl_desc = Tcl_open (ovf, tme, new_val_env, cl); + let od = { + open_expr = tme; + open_override = ovf; + open_loc = scl.pcl_loc; + open_env = new_val_env; + open_attributes = me.pmod_attributes + } in + rc {cl_desc = Tcl_open (od, cl); cl_loc = scl.pcl_loc; cl_type = cl.cl_type; cl_env = val_env; @@ -1777,7 +1785,7 @@ let rec unify_parents env ty cl = | _exn -> assert false end | Tcl_structure st -> unify_parents_struct env ty st - | Tcl_open (_, _, _, cl) + | Tcl_open (_, cl) | Tcl_fun (_, _, _, cl, _) | Tcl_apply (cl, _) | Tcl_let (_, _, _, cl) diff --git a/typing/typemod.ml b/typing/typemod.ml index 8f61dd144eed..71450d005b37 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -162,6 +162,7 @@ let type_open ?toplevel env sod = open_expr = tme; open_attributes = sod.popen_attributes; open_loc = sod.popen_loc; + open_env; } in inserted_md, open_env, od From 9fc3c6b1319e872492dbdcac1a98f1a54779da3f Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Sun, 18 Mar 2018 01:26:00 -0700 Subject: [PATCH 17/39] tast_mapper should map env in od --- typing/tast_mapper.ml | 27 ++++++++++++--------------- typing/tast_mapper.mli | 1 + 2 files changed, 13 insertions(+), 15 deletions(-) diff --git a/typing/tast_mapper.ml b/typing/tast_mapper.ml index cc1e1813741b..e78745ab2cc2 100644 --- a/typing/tast_mapper.ml +++ b/typing/tast_mapper.ml @@ -63,6 +63,7 @@ type mapper = (rec_flag * value_binding list); value_description: mapper -> value_description -> value_description; with_constraint: mapper -> with_constraint -> with_constraint; + open_description: mapper -> open_description -> open_description } let id x = x @@ -125,8 +126,7 @@ let structure_item sub {str_desc; str_loc; str_env} = (List.map (tuple3 id id (sub.class_type_declaration sub)) list) | Tstr_include incl -> Tstr_include (include_infos (sub.module_expr sub) incl) - | Tstr_open od -> - Tstr_open {od with open_expr = sub.module_expr sub od.open_expr} + | Tstr_open od -> Tstr_open (sub.open_description sub od) | Tstr_attribute _ as d -> d in {str_desc; str_env; str_loc} @@ -218,10 +218,7 @@ let expr sub x = Texp_constraint (sub.typ sub cty) | Texp_coerce (cty1, cty2) -> Texp_coerce (opt (sub.typ sub) cty1, sub.typ sub cty2) - | Texp_open od -> - Texp_open {od with - open_expr = sub.module_expr sub od.open_expr; - open_env = sub.env sub od.open_env} + | Texp_open od -> Texp_open (sub.open_description sub od) | Texp_newtype _ as d -> d | Texp_poly cto -> Texp_poly (opt (sub.typ sub) cto) in @@ -391,8 +388,7 @@ let signature_item sub x = | Tsig_class_type list -> Tsig_class_type (List.map (sub.class_type_declaration sub) list) - | Tsig_open od -> - Tsig_open {od with open_expr = sub.module_expr sub od.open_expr} + | Tsig_open od -> Tsig_open (sub.open_description sub od) | Tsig_attribute _ as d -> d in {x with sig_desc; sig_env} @@ -430,6 +426,11 @@ let with_constraint sub = function | Twith_module _ | Twith_modsubst _ as d -> d +let open_description sub od = + {od with + open_expr = sub.module_expr sub od.open_expr; + open_env = sub.env sub od.open_env} + let module_coercion sub = function | Tcoerce_none -> Tcoerce_none | Tcoerce_functor (c1,c2) -> @@ -527,10 +528,7 @@ let class_expr sub x = | Tcl_ident (path, lid, tyl) -> Tcl_ident (path, lid, List.map (sub.typ sub) tyl) | Tcl_open (od, e) -> - Tcl_open ( - {od with - open_expr = sub.module_expr sub od.open_expr; - open_env = sub.env sub od.open_env}, sub.class_expr sub e) + Tcl_open (sub.open_description sub od, sub.class_expr sub e) in {x with cl_desc; cl_env} @@ -552,9 +550,7 @@ let class_type sub x = sub.class_type sub cl ) | Tcty_open (od, e) -> - Tcty_open ({od with - open_expr = sub.module_expr sub od.open_expr; - open_env = sub.env sub od.open_env}, sub.class_type sub e) + Tcty_open (sub.open_description sub od, sub.class_type sub e) in {x with cltyp_desc; cltyp_env} @@ -706,4 +702,5 @@ let default = value_bindings; value_description; with_constraint; + open_description; } diff --git a/typing/tast_mapper.mli b/typing/tast_mapper.mli index 2251fa570941..8eb48cd06722 100644 --- a/typing/tast_mapper.mli +++ b/typing/tast_mapper.mli @@ -62,6 +62,7 @@ type mapper = (rec_flag * value_binding list); value_description: mapper -> value_description -> value_description; with_constraint: mapper -> with_constraint -> with_constraint; + open_description: mapper -> open_description -> open_description; } From 75d66d3d80d31ca24e4c14f145ed5e49c95a7351 Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Sun, 18 Mar 2018 02:32:59 -0700 Subject: [PATCH 18/39] merge cont --- typing/typemod.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/typing/typemod.ml b/typing/typemod.ml index 0f2f7cff1233..1e53558c3088 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -175,8 +175,9 @@ let initial_env ~loc ~safe_string ~initially_opened_module in let open_implicit_module env m = let open Asttypes in - let lid = {loc; txt = Longident.parse m } in - snd (type_open_ Override env lid.loc lid) + let me = Parsetree.({pmod_desc=Pmod_ident {loc; txt = Longident.parse m }; + pmod_loc=loc; pmod_attributes=[]}) in + let _, _, env = type_open_ Override env lid.loc lid in env in List.fold_left open_implicit_module env open_implicit_modules From c7334a4a01d3584bf3062127d04ed84c152b2ac5 Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Sun, 18 Mar 2018 14:01:11 -0700 Subject: [PATCH 19/39] fix type_open_ --- typing/typemod.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/typing/typemod.ml b/typing/typemod.ml index 1e53558c3088..21cf2b317720 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -177,7 +177,7 @@ let initial_env ~loc ~safe_string ~initially_opened_module let open Asttypes in let me = Parsetree.({pmod_desc=Pmod_ident {loc; txt = Longident.parse m }; pmod_loc=loc; pmod_attributes=[]}) in - let _, _, env = type_open_ Override env lid.loc lid in env + let _, _, env = type_open_ Override env loc me in env in List.fold_left open_implicit_module env open_implicit_modules From b3d830d4f0eb45b6812e4375e30564328cb77f06 Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Sun, 18 Mar 2018 14:26:21 -0700 Subject: [PATCH 20/39] printast for Pexp_open --- parsing/printast.ml | 2 +- .../parsing/shortcut_ext_attr.compilers.reference | 15 ++++++++++++--- 2 files changed, 13 insertions(+), 4 deletions(-) diff --git a/parsing/printast.ml b/parsing/printast.ml index 5966afdf4c5a..3fd8bd6c1aab 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -371,7 +371,7 @@ and expression i ppf x = line i ppf "Pexp_pack\n"; module_expr i ppf me | Pexp_open (ovf, m, e) -> - line i ppf "Pexp_open %a \"%a\"\n" fmt_override_flag ovf + line i ppf "Pexp_open %a\n%a\n" fmt_override_flag ovf (module_expr i) m; expression i ppf e | Pexp_extension (s, arg) -> diff --git a/testsuite/tests/parsing/shortcut_ext_attr.compilers.reference b/testsuite/tests/parsing/shortcut_ext_attr.compilers.reference index d8ceb058b223..d9becdf0ac50 100644 --- a/testsuite/tests/parsing/shortcut_ext_attr.compilers.reference +++ b/testsuite/tests/parsing/shortcut_ext_attr.compilers.reference @@ -56,7 +56,10 @@ expression (shortcut_ext_attr.ml[13,261+3]..[13,261+29]) attribute "foo" [] - Pexp_open Fresh ""M" (shortcut_ext_attr.ml[13,261+22]..[13,261+23])" + Pexp_open Fresh + module_expr (shortcut_ext_attr.ml[13,261+22]..[13,261+23]) + Pmod_ident "M" (shortcut_ext_attr.ml[13,261+22]..[13,261+23]) + expression (shortcut_ext_attr.ml[13,261+27]..[13,261+29]) Pexp_construct "()" (shortcut_ext_attr.ml[13,261+27]..[13,261+29]) None @@ -756,7 +759,10 @@ Pstr_extension "foo" [ structure_item (shortcut_ext_attr.ml[94,1905+0]..[94,1905+16]) - Pstr_open Fresh "M" (shortcut_ext_attr.ml[94,1905+15]..[94,1905+16]) + Pstr_open Fresh + module_expr (shortcut_ext_attr.ml[94,1905+15]..[94,1905+16]) + Pmod_ident "M" (shortcut_ext_attr.ml[94,1905+15]..[94,1905+16]) + attribute "foo" [] ] @@ -929,7 +935,10 @@ Psig_extension "foo" [ signature_item (shortcut_ext_attr.ml[115,2267+2]..[115,2267+18]) - Psig_open Fresh "M" (shortcut_ext_attr.ml[115,2267+17]..[115,2267+18]) + Psig_open Fresh + module_expr (shortcut_ext_attr.ml[115,2267+17]..[115,2267+18]) + Pmod_ident "M" (shortcut_ext_attr.ml[115,2267+17]..[115,2267+18]) + attribute "foo" [] ] From ab97d5ee370b9f6bc36678b59f8a9100cffb544d Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Mon, 19 Mar 2018 20:12:55 -0700 Subject: [PATCH 21/39] Pexp_open working --- typing/typeclass.ml | 8 ++++--- typing/typecore.ml | 57 ++++++++++++++++++++++++++++----------------- typing/typecore.mli | 6 ++++- typing/typemod.ml | 24 ++++++++++++------- 4 files changed, 61 insertions(+), 34 deletions(-) diff --git a/typing/typeclass.ml b/typing/typeclass.ml index e0f3aa00498d..7addaeba4fe6 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -554,7 +554,7 @@ and class_type_aux env scty = cltyp (Tcty_arrow (l, cty, clty)) typ | Pcty_open (ovf, me, e) -> - let (tme, newenv) = !Typecore.type_open ovf env scty.pcty_loc me in + let (_id, tme, newenv) = !Typecore.type_open ovf env scty.pcty_loc me in let clty = class_type newenv e in let od = { open_expr=tme; open_override=ovf; open_loc=scty.pcty_loc; @@ -1239,8 +1239,10 @@ and class_expr_aux cl_num val_env met_env scl = } | Pcl_open (ovf, me, e) -> let used_slot = ref false in - let (_, new_val_env) = !Typecore.type_open ~used_slot ovf val_env scl.pcl_loc me in - let (tme, new_met_env) = !Typecore.type_open ~used_slot ovf met_env scl.pcl_loc me in + let (_, _, new_val_env) = + !Typecore.type_open ~used_slot ovf val_env scl.pcl_loc me in + let (_id, tme, new_met_env) = + !Typecore.type_open ~used_slot ovf met_env scl.pcl_loc me in (* TODO(objmagic): what env to use here? *) let cl = class_expr cl_num new_val_env new_met_env e in let od = { diff --git a/typing/typecore.ml b/typing/typecore.ml index 6402a89f9006..0c6fdc93bc78 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -107,11 +107,15 @@ let type_module = ref ((fun _env _md -> assert false) : Env.t -> Parsetree.module_expr -> Typedtree.module_expr) +let gen_mod_ident : (Parsetree.module_expr -> string option) ref = ref (fun _ -> assert false) + (* Forward declaration, to be filled in by Typemod.type_open *) let type_open : (?used_slot:bool ref -> override_flag -> Env.t -> Location.t -> - Parsetree.module_expr -> Typedtree.module_expr * Env.t) + Parsetree.module_expr -> + (Ident.t * Types.module_declaration * Env.t) option * + Typedtree.module_expr * Env.t) ref = ref (fun ?used_slot:_ _ -> assert false) @@ -1412,14 +1416,18 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env (Tpat_type (path, lid), loc, sp.ppat_attributes) :: p.pat_extra } | Ppat_open (lid,p) -> let me = {pmod_desc=Pmod_ident lid; pmod_loc=lid.loc; pmod_attributes=[]} in - let _tme, new_env = - !type_open Asttypes.Fresh !env sp.ppat_loc me in - let new_env = ref new_env in - type_pat ~env:new_env p expected_ty ( fun p -> - env := Env.copy_local !env ~from:!new_env; - k { p with pat_extra =( Tpat_open (lid,!new_env), - loc, sp.ppat_attributes) :: p.pat_extra } - ) + let id, _tme, new_env = + !type_open Asttypes.Fresh !env sp.ppat_loc me in begin + match id with + | Some _ -> assert false + | None -> + let new_env = ref new_env in + type_pat ~env:new_env p expected_ty ( fun p -> + env := Env.copy_local !env ~from:!new_env; + k { p with pat_extra =( Tpat_open (lid,!new_env), + loc, sp.ppat_attributes) :: p.pat_extra } + ) + end | Ppat_exception _ -> raise (Error (loc, !env, Exception_pattern_below_toplevel)) | Ppat_extension ext -> @@ -3724,18 +3732,25 @@ and type_expect_ exp_type = newty (Tpackage (p, nl, tl')); exp_attributes = sexp.pexp_attributes; exp_env = env } - | Pexp_open (ovf, me, e) -> - let (tme, newenv) = !type_open ovf env sexp.pexp_loc me in - let exp = type_expect newenv e ty_expected_explained in - let od = { open_expr=tme; open_override=ovf; - open_loc=loc; open_env=newenv; (*TODO*) - open_attributes=sexp.pexp_attributes } in - { exp with - exp_extra = (Texp_open od, loc, - sexp.pexp_attributes) :: - exp.exp_extra; - } - + | Pexp_open (ovf, me, e) -> begin + match !gen_mod_ident me with + | None -> + let (_id, tme, newenv) = !type_open ovf env sexp.pexp_loc me in + let exp = type_expect newenv e ty_expected_explained in + let od = { open_expr=tme; open_override=ovf; + open_loc=loc; open_env=newenv; (*TODO*) + open_attributes=sexp.pexp_attributes } in + { exp with + exp_extra = (Texp_open od, loc, + sexp.pexp_attributes) :: + exp.exp_extra; + } + | Some id -> + let pmod = Pmod_ident ({txt=Longident.Lident id; loc}) in + let popen = Pexp_open (ovf, {me with pmod_desc = pmod}, e) in + let e = Pexp_letmodule ({txt=id;loc}, me, {sexp with pexp_desc=popen}) in + type_expect env {pexp_desc=e; pexp_loc=loc; pexp_attributes=[]} ty_expected_explained + end | Pexp_extension ({ txt = ("ocaml.extension_constructor" |"extension_constructor"); _ }, payload) -> diff --git a/typing/typecore.mli b/typing/typecore.mli index 93b6b82cfb91..db125e094680 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -174,7 +174,10 @@ val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref (* Forward declaration, to be filled in by Typemod.type_open *) val type_open: (?used_slot:bool ref -> override_flag -> Env.t -> Location.t -> - Parsetree.module_expr -> Typedtree.module_expr * Env.t) ref + Parsetree.module_expr -> + (Ident.t * Types.module_declaration * Env.t) option * + Typedtree.module_expr * Env.t) + ref (* Forward declaration, to be filled in by Typeclass.class_structure *) val type_object: (Env.t -> Location.t -> Parsetree.class_structure -> @@ -182,6 +185,7 @@ val type_object: val type_package: (Env.t -> Parsetree.module_expr -> Path.t -> Longident.t list -> Typedtree.module_expr * type_expr list) ref +val gen_mod_ident : (Parsetree.module_expr -> string option) ref val create_package_type : Location.t -> Env.t -> Longident.t * (Longident.t * Parsetree.core_type) list -> diff --git a/typing/typemod.ml b/typing/typemod.ml index 21cf2b317720..b7932072f7d0 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -198,7 +198,7 @@ let type_open ?toplevel env sod = open_env; } in - inserted_md, open_env, od + inserted_md, od (* Record a module type *) let rm node = @@ -650,8 +650,8 @@ and approx_sig env ssg = let (id, newenv) = Env.enter_modtype d.pmtd_name.txt info env in Sig_modtype(id, info) :: approx_sig newenv srem | Psig_open sod -> - let (_id, mty, _od) = type_open env sod in - approx_sig mty srem + let (_id, od) = type_open env sod in + approx_sig od.open_env srem | Psig_include sincl -> let smty = sincl.pincl_mod in let mty = approx_modtype env smty in @@ -957,7 +957,8 @@ and transl_signature env sg = sg :: rem, final_env | Psig_open sod -> begin - let (id, open_env, od) = type_open env sod in + let id, od = type_open env sod in + let open_env = od.open_env in let (trem, rem, final_env) = transl_sig open_env srem in match id with | None -> mksig (Tsig_open od) env loc :: trem, rem, final_env @@ -1706,7 +1707,8 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = mkstr (Tstr_modtype mtd) newenv loc :: str_rem, sg :: sig_rem, final_env | Pstr_open sod -> begin - let (inserted_md, open_env, od) = type_open ~toplevel env sod in + let (inserted_md, od) = type_open ~toplevel env sod in + let open_env = od.open_env in let str_rem, sig_rem, final_env = type_struct open_env srem in match inserted_md with | None -> mkstr (Tstr_open od) open_env loc :: str_rem, @@ -1931,10 +1933,13 @@ let type_package env m p nl = (* Fill in the forward declarations *) let type_open ?used_slot ovf env loc me = - let md, tme, env = type_open_ ?used_slot ?toplevel:None ovf env loc me in - match md with - | None -> tme, env - | Some _ -> assert false + type_open_ ?used_slot ?toplevel:None ovf env loc me + +let gen_mod_ident me = + match me.pmod_desc with + | Pmod_functor _ | Pmod_extension _ -> assert false + | Pmod_ident _ -> None + | _ -> Some((gen_mod_ident ()).Ident.name) let () = Typecore.type_module := type_module_alias; @@ -1942,6 +1947,7 @@ let () = Typetexp.transl_modtype := transl_modtype; Typecore.type_open := type_open; Typecore.type_package := type_package; + Typecore.gen_mod_ident := gen_mod_ident; type_module_fwd := type_module; type_module_type_of_fwd := type_module_type_of From a2745c15cc41659bbd2b2ea4c28d7aecf11114d8 Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Tue, 20 Mar 2018 22:35:30 -0700 Subject: [PATCH 22/39] add tests --- open_struct_A.ml | 4 ++ testsuite/tests/typing-modules/ocamltests | 1 + .../{open-struct.ml => open_struct.ml} | 41 +++++++++++++++++++ typing/typecore.ml | 17 ++++---- typing/typecore.mli | 2 +- typing/typemod.ml | 2 +- 6 files changed, 58 insertions(+), 9 deletions(-) create mode 100644 open_struct_A.ml rename testsuite/tests/typing-modules/{open-struct.ml => open_struct.ml} (81%) diff --git a/open_struct_A.ml b/open_struct_A.ml new file mode 100644 index 000000000000..e7043e4a6cdd --- /dev/null +++ b/open_struct_A.ml @@ -0,0 +1,4 @@ +let x = let module M = struct end in 1 + +let y = let open N in x + diff --git a/testsuite/tests/typing-modules/ocamltests b/testsuite/tests/typing-modules/ocamltests index f8c9fcdb51fc..9c7c19a334b4 100644 --- a/testsuite/tests/typing-modules/ocamltests +++ b/testsuite/tests/typing-modules/ocamltests @@ -2,6 +2,7 @@ aliases.ml applicative_functor_type.ml firstclass.ml generative.ml +open_struct.ml pr5911.ml pr6394.ml pr7207.ml diff --git a/testsuite/tests/typing-modules/open-struct.ml b/testsuite/tests/typing-modules/open_struct.ml similarity index 81% rename from testsuite/tests/typing-modules/open-struct.ml rename to testsuite/tests/typing-modules/open_struct.ml index f611fddaa6b3..020daa30dee3 100644 --- a/testsuite/tests/typing-modules/open-struct.ml +++ b/testsuite/tests/typing-modules/open_struct.ml @@ -1,3 +1,7 @@ +(* TEST + * expect +*) + type t = A [%%expect{| type t = A @@ -79,6 +83,8 @@ let () = include struct open struct type t = T end let x = T end [%%expect{| Line _, characters 15-41: + include struct open struct type t = T end let x = T end + ^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: The module identifier M#7 cannot be eliminated from val x : M#7.t |}];; @@ -106,6 +112,12 @@ module A = struct end [%%expect{| Line _, characters 2-74: + ..open struct + open struct + type t = T + end + let y = T + end Error: The module identifier M#10 cannot be eliminated from val g : M#10.M#11.t |}] @@ -113,6 +125,8 @@ Error: The module identifier M#10 cannot be eliminated from val g : module type S = sig open struct type t = T end val x : t end [%%expect{| Line _, characters 20-46: + module type S = sig open struct type t = T end val x : t end + ^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: The module identifier M#12 cannot be eliminated from val x : M#12.t |}];; @@ -253,5 +267,32 @@ module N = struct end [%%expect{| Line _, characters 24-50: + module type S = sig open struct type t = T end val x : t end + ^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: The module identifier M#31 cannot be eliminated from val x : M#31.t |}] + +let x = let open struct open struct let y = 1 end let x = y + 1 end in x +[%%expect{| +val x : int = 2 +|}] + +let y = + let + open ((functor (X: sig val x : int end) -> struct X.x end)(struct let x = 1 end)) + in x + +[%%expect{| +val y : int = 2 +|}] + +let x = let open struct type t = T end in T + +[%%expect{| +Line _, characters 42-43: + let x = let open struct type t = T end in T + ^ +Error: This expression has type M#35.t but an expression was expected of type + 'a + The type constructor M#35.t would escape its scope +|}] diff --git a/typing/typecore.ml b/typing/typecore.ml index 0c6fdc93bc78..2bf176744539 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -107,7 +107,7 @@ let type_module = ref ((fun _env _md -> assert false) : Env.t -> Parsetree.module_expr -> Typedtree.module_expr) -let gen_mod_ident : (Parsetree.module_expr -> string option) ref = ref (fun _ -> assert false) +let gen_mod_ident : (Parsetree.module_expr -> Ident.t option) ref = ref (fun _ -> assert false) (* Forward declaration, to be filled in by Typemod.type_open *) @@ -3735,21 +3735,24 @@ and type_expect_ | Pexp_open (ovf, me, e) -> begin match !gen_mod_ident me with | None -> - let (_id, tme, newenv) = !type_open ovf env sexp.pexp_loc me in + let (_id, tme, newenv) = !type_open ovf env loc me in let exp = type_expect newenv e ty_expected_explained in let od = { open_expr=tme; open_override=ovf; - open_loc=loc; open_env=newenv; (*TODO*) + open_loc=loc; open_env=newenv; open_attributes=sexp.pexp_attributes } in { exp with exp_extra = (Texp_open od, loc, sexp.pexp_attributes) :: exp.exp_extra; } - | Some id -> - let pmod = Pmod_ident ({txt=Longident.Lident id; loc}) in + | Some {Ident.name} -> + let pmod = Pmod_ident ({txt=Longident.Lident name; loc}) in let popen = Pexp_open (ovf, {me with pmod_desc = pmod}, e) in - let e = Pexp_letmodule ({txt=id;loc}, me, {sexp with pexp_desc=popen}) in - type_expect env {pexp_desc=e; pexp_loc=loc; pexp_attributes=[]} ty_expected_explained + let pexp_desc = Pexp_letmodule ({txt=name;loc}, me, + {sexp with pexp_desc=popen}) in + let sexp = {pexp_desc; pexp_loc=loc; + pexp_attributes=sexp.pexp_attributes} in + type_expect env sexp ty_expected_explained end | Pexp_extension ({ txt = ("ocaml.extension_constructor" |"extension_constructor"); _ }, diff --git a/typing/typecore.mli b/typing/typecore.mli index db125e094680..30b65b54ddd3 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -185,7 +185,7 @@ val type_object: val type_package: (Env.t -> Parsetree.module_expr -> Path.t -> Longident.t list -> Typedtree.module_expr * type_expr list) ref -val gen_mod_ident : (Parsetree.module_expr -> string option) ref +val gen_mod_ident : (Parsetree.module_expr -> Ident.t option) ref val create_package_type : Location.t -> Env.t -> Longident.t * (Longident.t * Parsetree.core_type) list -> diff --git a/typing/typemod.ml b/typing/typemod.ml index b7932072f7d0..4f370d4b5858 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -1939,7 +1939,7 @@ let gen_mod_ident me = match me.pmod_desc with | Pmod_functor _ | Pmod_extension _ -> assert false | Pmod_ident _ -> None - | _ -> Some((gen_mod_ident ()).Ident.name) + | _ -> Some(gen_mod_ident ()) let () = Typecore.type_module := type_module_alias; From d56579a51409b3ff7c92308752d45c8dd00de29f Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Sun, 25 Mar 2018 12:21:11 -0700 Subject: [PATCH 23/39] remove unused file --- testsuite/w7.ml | 0 1 file changed, 0 insertions(+), 0 deletions(-) delete mode 100644 testsuite/w7.ml diff --git a/testsuite/w7.ml b/testsuite/w7.ml deleted file mode 100644 index e69de29bb2d1..000000000000 From ca36b0d4fdedf8d2f1bc5fc19fbf190661cca37b Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Sun, 25 Mar 2018 12:36:22 -0700 Subject: [PATCH 24/39] clean up and and more tests. --- open_struct_A.ml | 4 ---- testsuite/tests/typing-modules/open_struct.ml | 22 +++++++++++++++++++ 2 files changed, 22 insertions(+), 4 deletions(-) delete mode 100644 open_struct_A.ml diff --git a/open_struct_A.ml b/open_struct_A.ml deleted file mode 100644 index e7043e4a6cdd..000000000000 --- a/open_struct_A.ml +++ /dev/null @@ -1,4 +0,0 @@ -let x = let module M = struct end in 1 - -let y = let open N in x - diff --git a/testsuite/tests/typing-modules/open_struct.ml b/testsuite/tests/typing-modules/open_struct.ml index 020daa30dee3..243860d7959b 100644 --- a/testsuite/tests/typing-modules/open_struct.ml +++ b/testsuite/tests/typing-modules/open_struct.ml @@ -296,3 +296,25 @@ Error: This expression has type M#35.t but an expression was expected of type 'a The type constructor M#35.t would escape its scope |}] + +module type Print = sig + type t + val print: t -> unit +end + +module Print_int: Print with type t = int = struct + type t = int let print = print_int +end +module Print_list(P: Print): Print with type t = P.t list = struct + type t = P.t list + let print = List.iter P.print +end +let print_list_of_int = let open Print_list(Print_int) in print + +[%%expect{| +module type Print = sig type t val print : t -> unit end +module Print_int : sig type t = int val print : t -> unit end +module Print_list : + functor (P : Print) -> sig type t = P.t list val print : t -> unit end +val print_list_of_int : Print_int.t list -> unit = +|}] From 1ad2061766413b301c8c9392c4b0e8f9040842bd Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Sun, 25 Mar 2018 23:54:28 -0700 Subject: [PATCH 25/39] some clean-ups --- typing/typecore.ml | 4 ++-- typing/typemod.ml | 12 +++++++----- 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/typing/typecore.ml b/typing/typecore.ml index 409a9fa13bb0..7ba0e4e0421b 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -1414,7 +1414,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env k { p with pat_extra = (Tpat_type (path, lid), loc, sp.ppat_attributes) :: p.pat_extra } | Ppat_open (lid,p) -> - let me = {pmod_desc=Pmod_ident lid; pmod_loc=lid.loc; pmod_attributes=[]} in + let me = Ast_helper.Mod.ident ~loc:lid.loc ~attrs:[] lid in let id, _tme, new_env = !type_open Asttypes.Fresh !env sp.ppat_loc me in begin match id with @@ -2214,6 +2214,7 @@ struct | Tstr_modtype _ -> Env.empty, Use.empty | Tstr_open _ -> + (* TODO(objmagic) adapt to GPR#556 *) Env.empty, Use.empty | Tstr_class classes -> (* Any occurrence in a class definition is counted as a use, @@ -2249,7 +2250,6 @@ struct | Tcl_constraint (ce, _, _, _, _) -> class_expr env ce | Tcl_open (_, ce) -> - (* TODO DEP *) class_expr env ce and case : Env.env -> Typedtree.case -> scrutinee:Use.t -> Use.t = fun env { Typedtree.c_lhs; c_guard; c_rhs } ~scrutinee:ty -> diff --git a/typing/typemod.ml b/typing/typemod.ml index 1fe5420fd22d..be4a1856018e 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -110,8 +110,9 @@ let type_open_ ?used_slot ?toplevel ovf env loc me = match me.pmod_desc with | Pmod_functor _ | Pmod_extension _ -> raise(Error(me.pmod_loc, env, Invalid_open me)) - | Pmod_ident lid -> begin + | Pmod_ident lid -> let path = Typetexp.lookup_module ~load:true env lid.loc lid.txt in + begin match Env.open_signature ~loc ?used_slot ?toplevel ovf path env with | Some env -> let tme = @@ -124,10 +125,11 @@ let type_open_ ?used_slot ?toplevel ovf env loc me = } in None, tme, env | None -> + (* use [extract_sig_open] to provide better error message *) let md = Env.find_module path env in ignore (extract_sig_open env lid.loc md.md_type); assert false - end + end | Pmod_structure _ | Pmod_apply _ | Pmod_constraint _ | Pmod_unpack _ -> enter_struct (); let ident = gen_mod_ident () in @@ -135,8 +137,8 @@ let type_open_ ?used_slot ?toplevel ovf env loc me = leave_struct (); (match tme.mod_type with | Mty_signature _ | Mty_ident _ -> () - | Mty_functor _ | Mty_alias _ -> - raise(Error(me.pmod_loc, env, Invalid_open me))); + | Mty_functor _ -> raise(Error(me.pmod_loc, env, Invalid_open me)) + | Mty_alias _ -> assert false); let md = { md_type = tme.mod_type; md_loc = me.pmod_loc; @@ -145,7 +147,7 @@ let type_open_ ?used_slot ?toplevel ovf env loc me = let newenv = Env.enter_module_declaration ident md env in let root = Pident ident in match Env.open_signature ~loc ?used_slot ?toplevel ovf root newenv with - | None -> assert false (* not possible to open a Mty_functor *) + | None -> assert false (* not possible to illegal module_expr *) | Some opened_env -> Some (ident, md, newenv), tme, opened_env let type_initially_opened_module env module_name = From 6856b39c6f7c2a9a26d464ef35d97eeef94da522 Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Wed, 28 Mar 2018 15:13:16 -0700 Subject: [PATCH 26/39] style and minor improv --- testsuite/tests/typing-modules/open_struct.ml | 19 +++++++++++++++ typing/typeclass.ml | 1 - typing/typecore.ml | 2 +- typing/typemod.ml | 23 ++++++++++--------- 4 files changed, 32 insertions(+), 13 deletions(-) diff --git a/testsuite/tests/typing-modules/open_struct.ml b/testsuite/tests/typing-modules/open_struct.ml index 243860d7959b..69dbd0c3e904 100644 --- a/testsuite/tests/typing-modules/open_struct.ml +++ b/testsuite/tests/typing-modules/open_struct.ml @@ -318,3 +318,22 @@ module Print_list : functor (P : Print) -> sig type t = P.t list val print : t -> unit end val print_list_of_int : Print_int.t list -> unit = |}] + +let f () = let open [%foo] in ();; + +[%%expect{| +Line _, characters 20-26: + let f () = let open [%foo] in ();; + ^^^^^^ +Error: Invalid open +|}] + + +let f () = let open functor(X: sig end) -> struct end in ();; + +[%%expect{| +Line _, characters 20-53: + let f () = let open functor(X: sig end) -> struct end in ();; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Invalid open +|}] diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 7addaeba4fe6..c066d33de7bb 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -1243,7 +1243,6 @@ and class_expr_aux cl_num val_env met_env scl = !Typecore.type_open ~used_slot ovf val_env scl.pcl_loc me in let (_id, tme, new_met_env) = !Typecore.type_open ~used_slot ovf met_env scl.pcl_loc me in - (* TODO(objmagic): what env to use here? *) let cl = class_expr cl_num new_val_env new_met_env e in let od = { open_expr = tme; diff --git a/typing/typecore.ml b/typing/typecore.ml index 7ba0e4e0421b..145a277636e2 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -1418,7 +1418,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env let id, _tme, new_env = !type_open Asttypes.Fresh !env sp.ppat_loc me in begin match id with - | Some _ -> assert false + | Some _ -> assert false (* not possible due to syntactic restriction *) | None -> let new_env = ref new_env in type_pat ~env:new_env p expected_ty ( fun p -> diff --git a/typing/typemod.ml b/typing/typemod.ml index be4a1856018e..7f6d7a2e3980 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -177,8 +177,8 @@ let initial_env ~loc ~safe_string ~initially_opened_module in let open_implicit_module env m = let open Asttypes in - let me = Parsetree.({pmod_desc=Pmod_ident {loc; txt = Longident.parse m }; - pmod_loc=loc; pmod_attributes=[]}) in + let me = Ast_helper.Mod.ident ~loc ~attrs:[] + {loc; txt = Longident.parse m } in let _, _, env = type_open_ Override env loc me in env in List.fold_left open_implicit_module env open_implicit_modules @@ -779,7 +779,7 @@ let remove_inserted_modtype mty = | None -> None | Some mty -> Some (aux mty)), (aux mty_res)) - | mty -> mty in + | (Mty_ident _ | Mty_alias _) as mty -> mty in aux mty let has_remove_aliases_attribute attr = @@ -969,10 +969,10 @@ and transl_signature env sg = mksig (Tsig_modtype mtd) env loc :: trem, sg :: rem, final_env - | Psig_open sod -> begin + | Psig_open sod -> let id, od = type_open env sod in let open_env = od.open_env in - let (trem, rem, final_env) = transl_sig open_env srem in + let (trem, rem, final_env) = transl_sig open_env srem in begin match id with | None -> mksig (Tsig_open od) env loc :: trem, rem, final_env | Some (id, _md, _env) -> @@ -984,7 +984,7 @@ and transl_signature env sg = raise(Error(sod.popen_loc, env, Cannot_eliminate_anon_module(id, rem))) | _ -> assert false - end + end | Psig_include sincl -> let smty = sincl.pincl_mod in let tmty = @@ -1719,10 +1719,11 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = let str_rem, sig_rem, final_env = type_struct newenv srem in mkstr (Tstr_modtype mtd) newenv loc :: str_rem, sg :: sig_rem, final_env - | Pstr_open sod -> begin + | Pstr_open sod -> let (inserted_md, od) = type_open ~toplevel env sod in let open_env = od.open_env in let str_rem, sig_rem, final_env = type_struct open_env srem in + begin match inserted_md with | None -> mkstr (Tstr_open od) open_env loc :: str_rem, sig_rem, final_env @@ -1749,7 +1750,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = | Mty_ident _ | Mty_functor _ | Mty_alias _ -> assert false else tm_str :: open_str :: str_rem, md_sig :: sig_rem, final_env - end + end | Pstr_class cl -> List.iter (fun {pci_name} -> check_name check_type names pci_name) @@ -1951,9 +1952,9 @@ let type_open ?used_slot ovf env loc me = let gen_mod_ident me = match me.pmod_desc with - | Pmod_functor _ | Pmod_extension _ -> assert false - | Pmod_ident _ -> None - | _ -> Some(gen_mod_ident ()) + | Pmod_functor _ | Pmod_extension _ | Pmod_ident _ -> None + | Pmod_structure _ | Pmod_apply _ | Pmod_constraint _ | Pmod_unpack _ -> + Some(gen_mod_ident ()) let () = Typecore.type_module := type_module_alias; From c3e48452ad94be4c76f9abe108a400d9e44f4cef Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Thu, 29 Mar 2018 13:55:40 -0700 Subject: [PATCH 27/39] Ppat_open only accepts id. --- parsing/ast_invariants.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/parsing/ast_invariants.ml b/parsing/ast_invariants.ml index 8361387f8935..8b0e156478e3 100644 --- a/parsing/ast_invariants.ml +++ b/parsing/ast_invariants.ml @@ -67,6 +67,7 @@ let iterator = | Ppat_construct (id, _) -> simple_longident id | Ppat_record (fields, _) -> List.iter (fun (id, _) -> simple_longident id) fields + | Ppat_open (id, _) -> simple_longident id | _ -> () in let expr self exp = From 39a17eaf2273291a3902c376b164fd86c1ea530e Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Thu, 29 Mar 2018 13:56:13 -0700 Subject: [PATCH 28/39] minor --- typing/typecore.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/typing/typecore.ml b/typing/typecore.ml index 145a277636e2..7ba0e4e0421b 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -1418,7 +1418,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env let id, _tme, new_env = !type_open Asttypes.Fresh !env sp.ppat_loc me in begin match id with - | Some _ -> assert false (* not possible due to syntactic restriction *) + | Some _ -> assert false | None -> let new_env = ref new_env in type_pat ~env:new_env p expected_ty ( fun p -> From 97e9cb034feb16d1abdf7d0f073991db5fa65165 Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Thu, 29 Mar 2018 13:56:35 -0700 Subject: [PATCH 29/39] save progress --- typing/typemod.ml | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/typing/typemod.ml b/typing/typemod.ml index 7f6d7a2e3980..ca3697e61371 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -96,8 +96,7 @@ let mod_ident_counter = ref 0 let gen_mod_ident () = let n = !mod_ident_counter in incr mod_ident_counter; - let ident = Ident.create (Printf.sprintf "M#%d" n) in - ident + Ident.create (Printf.sprintf "M#%d" n) let open_struct_level = ref 0 let in_nested_struct () = !open_struct_level <> 0 @@ -1852,8 +1851,9 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = let type_toplevel_phrase env s = Env.reset_required_globals (); let (str, sg, env) = - Misc.protect_refs [R(open_struct_level, 0)] (fun () -> - type_structure ~toplevel:true false None env s Location.none) in + Misc.protect_refs [R(open_struct_level, 0)] + (fun () -> + type_structure ~toplevel:true false None env s Location.none) in let (str, _coerce) = ImplementationHooks.apply_hooks { Misc.sourcefile = "//toplevel//" } (str, Tcoerce_none) in @@ -1986,8 +1986,10 @@ let simplify_signature sg = let (sg, _) = aux sg in sg +(* TODO: protect mod_ident_counter does not work: break debugger test *) let type_implementation sourcefile outputprefix modulename initial_env ast = - Misc.protect_refs [R(open_struct_level, 0)] (fun () -> + Misc.protect_refs [R(open_struct_level, 0)] + (fun () -> Cmt_format.clear (); try Typecore.reset_delayed_checks (); From 0be2af487112affc75b5587818ae2667558d74b7 Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Sun, 1 Apr 2018 01:55:55 -0700 Subject: [PATCH 30/39] use extract, clean-ups --- testsuite/tests/typing-modules/open_struct.ml | 13 +--- typing/typemod.ml | 72 +++++++++---------- 2 files changed, 38 insertions(+), 47 deletions(-) diff --git a/testsuite/tests/typing-modules/open_struct.ml b/testsuite/tests/typing-modules/open_struct.ml index 69dbd0c3e904..0673296e12d0 100644 --- a/testsuite/tests/typing-modules/open_struct.ml +++ b/testsuite/tests/typing-modules/open_struct.ml @@ -319,21 +319,12 @@ module Print_list : val print_list_of_int : Print_int.t list -> unit = |}] -let f () = let open [%foo] in ();; - -[%%expect{| -Line _, characters 20-26: - let f () = let open [%foo] in ();; - ^^^^^^ -Error: Invalid open -|}] - - let f () = let open functor(X: sig end) -> struct end in ();; [%%expect{| Line _, characters 20-53: let f () = let open functor(X: sig end) -> struct end in ();; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Invalid open +Error: This module is not a structure; it has type + functor (X : sig end) -> sig end |}] diff --git a/typing/typemod.ml b/typing/typemod.ml index 6155f0e56656..b6c4d9de9b26 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -106,9 +106,11 @@ let leave_struct () = decr open_struct_level let open_generated s = String.contains s '#' let type_open_ ?used_slot ?toplevel ovf env loc me = + let report_illegal_mt mt loc env = + ignore (extract_sig_open env loc mt); + assert false + in match me.pmod_desc with - | Pmod_functor _ | Pmod_extension _ -> - raise(Error(me.pmod_loc, env, Invalid_open me)) | Pmod_ident lid -> let path = Typetexp.lookup_module ~load:true env lid.loc lid.txt in begin @@ -124,20 +126,15 @@ let type_open_ ?used_slot ?toplevel ovf env loc me = } in None, tme, env | None -> - (* use [extract_sig_open] to provide better error message *) - let md = Env.find_module path env in - ignore (extract_sig_open env lid.loc md.md_type); - assert false + let mt = (Env.find_module path env).md_type in + report_illegal_mt mt lid.loc env end - | Pmod_structure _ | Pmod_apply _ | Pmod_constraint _ | Pmod_unpack _ -> + | Pmod_structure _ | Pmod_apply _ | Pmod_constraint _ | Pmod_unpack _ | + Pmod_functor _ | Pmod_extension _ -> enter_struct (); let ident = gen_mod_ident () in let tme = !type_module_fwd env me in leave_struct (); - (match tme.mod_type with - | Mty_signature _ | Mty_ident _ -> () - | Mty_functor _ -> raise(Error(me.pmod_loc, env, Invalid_open me)) - | Mty_alias _ -> assert false); let md = { md_type = tme.mod_type; md_loc = me.pmod_loc; @@ -146,7 +143,7 @@ let type_open_ ?used_slot ?toplevel ovf env loc me = let newenv = Env.enter_module_declaration ident md env in let root = Pident ident in match Env.open_signature ~loc ?used_slot ?toplevel ovf root newenv with - | None -> assert false (* not possible to illegal module_expr *) + | None -> report_illegal_mt tme.mod_type me.pmod_loc env | Some opened_env -> Some (ident, md, newenv), tme, opened_env let type_initially_opened_module env module_name = @@ -972,17 +969,19 @@ and transl_signature env sg = let id, od = type_open env sod in let open_env = od.open_env in let (trem, rem, final_env) = transl_sig open_env srem in begin - match id with - | None -> mksig (Tsig_open od) env loc :: trem, rem, final_env - | Some (id, _md, _env) -> - let s_rem = Mty_signature rem in - match Mtype.nondep_supertype open_env id s_rem with - | Mty_signature rem' -> - mksig (Tsig_open od) env loc :: trem, rem', final_env - | exception Not_found -> - raise(Error(sod.popen_loc, env, - Cannot_eliminate_anon_module(id, rem))) - | _ -> assert false + let rem = + match id with + | None -> rem + | Some (id, _md, _env) -> + let s_rem = Mty_signature rem in + match Mtype.nondep_supertype open_env id s_rem with + | Mty_signature rem' -> rem' + | exception Not_found -> + raise(Error(sod.popen_loc, env, + Cannot_eliminate_anon_module(id, rem))) + | Mty_ident _ | Mty_functor _ | Mty_alias _ -> assert false + in + mksig (Tsig_open od) env loc :: trem, rem, final_env end | Psig_include sincl -> let smty = sincl.pincl_mod in @@ -1733,22 +1732,23 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = mb_expr = od.open_expr; mb_attributes=od.open_expr.mod_attributes; mb_loc=od.open_expr.mod_loc} in - let tm_str = { str_desc = tm; str_loc = loc; str_env = md_env } in + let tm_str = { str_desc = tm; str_loc = loc; + str_env = md_env } in let open_str = mkstr (Tstr_open od) open_env loc in let md_sig = Sig_module (id, {md_type=md.Types.md_type; md_loc=loc; md_attributes = []}, Trec_not) in - if not (in_nested_struct ()) then - let s_rem = Mty_signature sig_rem in - match Mtype.nondep_supertype open_env id s_rem with - | Mty_signature sg -> - tm_str :: open_str :: str_rem, md_sig :: sg, final_env - | exception Not_found -> - raise (Error(loc, env, - Cannot_eliminate_anon_module(id, sig_rem))) - | Mty_ident _ | Mty_functor _ | Mty_alias _ -> assert false - else - tm_str :: open_str :: str_rem, md_sig :: sig_rem, final_env + let sg = + if not (in_nested_struct ()) then + let s_rem = Mty_signature sig_rem in + match Mtype.nondep_supertype open_env id s_rem with + | Mty_signature sg -> sg + | exception Not_found -> + raise (Error(loc, env, + Cannot_eliminate_anon_module(id, sig_rem))) + | Mty_ident _ | Mty_functor _ | Mty_alias _ -> assert false + else sig_rem in + tm_str :: open_str :: str_rem, md_sig :: sg, final_env end | Pstr_class cl -> List.iter @@ -1952,7 +1952,7 @@ let type_open ?used_slot ovf env loc me = let gen_mod_ident me = match me.pmod_desc with - | Pmod_functor _ | Pmod_extension _ | Pmod_ident _ -> None + | Pmod_functor _ | Pmod_extension _ | Pmod_ident _ -> None | Pmod_structure _ | Pmod_apply _ | Pmod_constraint _ | Pmod_unpack _ -> Some(gen_mod_ident ()) From 76760bd78ac85018b42f2e7ff9954ab387242d70 Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Sun, 1 Apr 2018 02:37:20 -0700 Subject: [PATCH 31/39] comment for `assert false` --- typing/typecore.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/typing/typecore.ml b/typing/typecore.ml index 1fbfc15e26d3..c0b0bcb21231 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -1418,7 +1418,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env let id, _tme, new_env = !type_open Asttypes.Fresh !env sp.ppat_loc me in begin match id with - | Some _ -> assert false + | Some _ -> assert false (* not possible due to syntactic restriction *) | None -> let new_env = ref new_env in type_pat ~env:new_env p expected_ty ( fun p -> From b8a0d8fc6ef1ec466685f62aafa9b6982b703f34 Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Sun, 1 Apr 2018 03:31:36 -0700 Subject: [PATCH 32/39] protect mod_ident_counter --- typing/typemod.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/typing/typemod.ml b/typing/typemod.ml index b6c4d9de9b26..116db3ab5333 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -1986,9 +1986,9 @@ let simplify_signature sg = let (sg, _) = aux sg in sg -(* TODO: protect mod_ident_counter does not work: break debugger test *) +(* TODO(objmagic): protect mod_ident_counter does not work: break debugger test *) let type_implementation sourcefile outputprefix modulename initial_env ast = - Misc.protect_refs [R(open_struct_level, 0)] + Misc.protect_refs [R(open_struct_level, 0); R(mod_ident_counter, 0)] (fun () -> Cmt_format.clear (); try From 20b2f0f0dfba2b6695ed64898ee001d92651f421 Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Sun, 1 Apr 2018 03:35:19 -0700 Subject: [PATCH 33/39] rm comment --- typing/typemod.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/typing/typemod.ml b/typing/typemod.ml index 116db3ab5333..59f1ffd99b40 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -1986,7 +1986,6 @@ let simplify_signature sg = let (sg, _) = aux sg in sg -(* TODO(objmagic): protect mod_ident_counter does not work: break debugger test *) let type_implementation sourcefile outputprefix modulename initial_env ast = Misc.protect_refs [R(open_struct_level, 0); R(mod_ident_counter, 0)] (fun () -> From f061df16298edaefe4ec9019cc9e8812d4b29ada Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Mon, 2 Apr 2018 22:29:00 -0700 Subject: [PATCH 34/39] no need to adapt to GPR#556 --- typing/typecore.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/typing/typecore.ml b/typing/typecore.ml index c0b0bcb21231..9fa54c0dcd2d 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -2214,7 +2214,6 @@ struct | Tstr_modtype _ -> Env.empty, Use.empty | Tstr_open _ -> - (* TODO(objmagic) adapt to GPR#556 *) Env.empty, Use.empty | Tstr_class classes -> (* Any occurrence in a class definition is counted as a use, From 8ecdac83ba073a5f1aa6ea2f9bcd3355e50dab97 Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Mon, 2 Apr 2018 22:50:44 -0700 Subject: [PATCH 35/39] remove a TODO --- typing/tast_mapper.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/typing/tast_mapper.ml b/typing/tast_mapper.ml index e78745ab2cc2..58beec7576c6 100644 --- a/typing/tast_mapper.ml +++ b/typing/tast_mapper.ml @@ -17,7 +17,7 @@ open Asttypes open Typedtree (* TODO: add 'methods' for location, attribute, extension, - open_description, include_declaration, include_description *) + include_declaration, include_description *) type mapper = { From ef9c107c714740a323b5ebb44b48172a3a2bc538 Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Mon, 2 Apr 2018 22:59:46 -0700 Subject: [PATCH 36/39] update parsing tests. --- testsuite/tests/parsetree/source.ml | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/testsuite/tests/parsetree/source.ml b/testsuite/tests/parsetree/source.ml index 3aecad9cec9c..c25fc1f157ef 100644 --- a/testsuite/tests/parsetree/source.ml +++ b/testsuite/tests/parsetree/source.ml @@ -7407,3 +7407,9 @@ module type T = sig type s = int end module F(X:S) : T = X module G(X:T) : S = X type t = | + +let x = let open struct type t = int let x = 1 end in x +let y = + let + open ((functor (X: sig val x : int end) -> struct X.x end)(struct let x = 1 end)) + in x From 1b2349f7ec73211b1b5599e7c2397da6c7e67926 Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Mon, 2 Apr 2018 23:16:43 -0700 Subject: [PATCH 37/39] no need for Invalid_open --- typing/typemod.ml | 3 --- typing/typemod.mli | 1 - 2 files changed, 4 deletions(-) diff --git a/typing/typemod.ml b/typing/typemod.ml index 59f1ffd99b40..1845a3f12e4d 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -46,7 +46,6 @@ type error = | Recursive_module_require_explicit_type | Apply_generative | Cannot_scrape_alias of Path.t - | Invalid_open of Parsetree.module_expr | Cannot_eliminate_anon_module of Ident.t * signature exception Error of Location.t * Env.t * error @@ -2235,8 +2234,6 @@ let report_error ppf = function fprintf ppf "This is an alias for module %a, which is missing" path p - | Invalid_open _me -> - fprintf ppf "Invalid open" | Cannot_eliminate_anon_module (id, sg) -> fprintf ppf "The module identifier %a cannot be \ eliminated from %a" ident id signature sg diff --git a/typing/typemod.mli b/typing/typemod.mli index 1c908fe2c256..78e101b1999a 100644 --- a/typing/typemod.mli +++ b/typing/typemod.mli @@ -86,7 +86,6 @@ type error = | Recursive_module_require_explicit_type | Apply_generative | Cannot_scrape_alias of Path.t - | Invalid_open of Parsetree.module_expr | Cannot_eliminate_anon_module of Ident.t * signature exception Error of Location.t * Env.t * error From ef514bb538bf696c699522e1bd2e161ddcb90637 Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Sun, 8 Apr 2018 01:51:07 -0700 Subject: [PATCH 38/39] update tests --- testsuite/tests/typing-modules/open_struct.ml | 26 ++++++++++++++----- 1 file changed, 19 insertions(+), 7 deletions(-) diff --git a/testsuite/tests/typing-modules/open_struct.ml b/testsuite/tests/typing-modules/open_struct.ml index 0673296e12d0..5dd95a1fecef 100644 --- a/testsuite/tests/typing-modules/open_struct.ml +++ b/testsuite/tests/typing-modules/open_struct.ml @@ -65,6 +65,18 @@ end module M : S |}];; +module M = struct + module M (F: sig end) (X: sig end) = struct end + open M(struct end) +end +[%%expect{| +Line _, characters 7-20: + open M(struct end) + ^^^^^^^^^^^^^ +Error: This module is not a structure; it has type + functor (X : sig end) -> sig end +|}] + open struct open struct let counter = ref 0 end let inc () = incr counter @@ -85,7 +97,7 @@ include struct open struct type t = T end let x = T end Line _, characters 15-41: include struct open struct type t = T end let x = T end ^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: The module identifier M#7 cannot be eliminated from val x : M#7.t +Error: The module identifier M#8 cannot be eliminated from val x : M#8.t |}];; module A = struct @@ -118,8 +130,8 @@ Line _, characters 2-74: end let y = T end -Error: The module identifier M#10 cannot be eliminated from val g : - M#10.M#11.t +Error: The module identifier M#11 cannot be eliminated from val g : + M#11.M#12.t |}] module type S = sig open struct type t = T end val x : t end @@ -127,7 +139,7 @@ module type S = sig open struct type t = T end val x : t end Line _, characters 20-46: module type S = sig open struct type t = T end val x : t end ^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: The module identifier M#12 cannot be eliminated from val x : M#12.t +Error: The module identifier M#13 cannot be eliminated from val x : M#13.t |}];; @@ -269,7 +281,7 @@ end Line _, characters 24-50: module type S = sig open struct type t = T end val x : t end ^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: The module identifier M#31 cannot be eliminated from val x : M#31.t +Error: The module identifier M#32 cannot be eliminated from val x : M#32.t |}] let x = let open struct open struct let y = 1 end let x = y + 1 end in x @@ -292,9 +304,9 @@ let x = let open struct type t = T end in T Line _, characters 42-43: let x = let open struct type t = T end in T ^ -Error: This expression has type M#35.t but an expression was expected of type +Error: This expression has type M#36.t but an expression was expected of type 'a - The type constructor M#35.t would escape its scope + The type constructor M#36.t would escape its scope |}] module type Print = sig From 33bebaddf1bc444d733ca4b0b693c1dc76dbff4f Mon Sep 17 00:00:00 2001 From: Runhang Li Date: Sun, 8 Apr 2018 01:51:15 -0700 Subject: [PATCH 39/39] style --- typing/typemod.ml | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/typing/typemod.ml b/typing/typemod.ml index 1845a3f12e4d..de478bbeb6c6 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -967,9 +967,9 @@ and transl_signature env sg = | Psig_open sod -> let id, od = type_open env sod in let open_env = od.open_env in - let (trem, rem, final_env) = transl_sig open_env srem in begin + let (trem, rem, final_env) = transl_sig open_env srem in let rem = - match id with + begin match id with | None -> rem | Some (id, _md, _env) -> let s_rem = Mty_signature rem in @@ -979,9 +979,8 @@ and transl_signature env sg = raise(Error(sod.popen_loc, env, Cannot_eliminate_anon_module(id, rem))) | Mty_ident _ | Mty_functor _ | Mty_alias _ -> assert false - in + end in mksig (Tsig_open od) env loc :: trem, rem, final_env - end | Psig_include sincl -> let smty = sincl.pincl_mod in let tmty =