From 16af8dbf562e5aa8676f4de7016d48cc40cbed5c Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Mon, 4 Dec 2017 16:26:43 +0000 Subject: [PATCH] Allow compilation units to shadow sub-modules of Pervasives --- Changes | 4 ++ driver/compmisc.ml | 23 ++----- ocamldoc/odoc_analyse.ml | 24 ++----- .../largeFile.ml | 1 + .../ocamltests | 1 + .../redefine_largefile.ml | 4 ++ .../redefine_largefile.reference | 1 + typing/env.ml | 63 +++++++++++++++---- typing/env.mli | 24 ++++++- typing/envaux.ml | 5 +- typing/typemod.ml | 31 +++++++++ typing/typemod.mli | 8 ++- 12 files changed, 136 insertions(+), 53 deletions(-) create mode 100644 testsuite/tests/typing-shadowing-of-pervasives-submodules/largeFile.ml create mode 100644 testsuite/tests/typing-shadowing-of-pervasives-submodules/ocamltests create mode 100644 testsuite/tests/typing-shadowing-of-pervasives-submodules/redefine_largefile.ml create mode 100644 testsuite/tests/typing-shadowing-of-pervasives-submodules/redefine_largefile.reference diff --git a/Changes b/Changes index 7cd77889cbb2..131e458e401e 100644 --- a/Changes +++ b/Changes @@ -26,6 +26,10 @@ Working version - GPR#1583: propagate refined ty_arg to Parmatch checks (Thomas Refis, review by Jacques Garrigue) +- GPR#1513: Allow compilation units to shadow sub-modules of Pervasives. + For instance users can now use a largeFile.ml file in their project. + (Jérémie Dimino, review by Nicolas Ojeda Bar, Alain Frisch and Gabriel Radanne) + ### Standard library: - MPR#7690, GPR#1528: fix the float_of_string function for hexadecimal floats diff --git a/driver/compmisc.ml b/driver/compmisc.ml index a0839f34ca55..08dc670d3d7c 100644 --- a/driver/compmisc.ml +++ b/driver/compmisc.ml @@ -43,26 +43,13 @@ let init_path ?(dir="") native = (* Note: do not do init_path() in initial_env, this breaks toplevel initialization (PR#1775) *) -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 initial_env () = Ident.reinit(); - let initial = - if Config.safe_string then Env.initial_safe_string - else if !Clflags.unsafe_string then Env.initial_unsafe_string - else Env.initial_safe_string - in - let env = - if !Clflags.nopervasives then initial else - open_implicit_module "Pervasives" initial - in - List.fold_left (fun env m -> - open_implicit_module m env - ) env (!implicit_modules @ List.rev !Clflags.open_modules) + Typemod.initial_env + ~loc:(Location.in_file "command line") + ~safe_string:(Config.safe_string || not !Clflags.unsafe_string) + ~open_pervasives:(not !Clflags.nopervasives) + ~open_implicit_modules:(!implicit_modules @ List.rev !Clflags.open_modules) let read_color_env ppf = diff --git a/ocamldoc/odoc_analyse.ml b/ocamldoc/odoc_analyse.ml index 1393d571c1d6..13c128a4db48 100644 --- a/ocamldoc/odoc_analyse.ml +++ b/ocamldoc/odoc_analyse.ml @@ -33,25 +33,11 @@ let init_path () = (** Return the initial environment in which compilation proceeds. *) let initial_env () = - let initial = - if Config.safe_string then Env.initial_safe_string - else if !Clflags.unsafe_string then Env.initial_unsafe_string - else Env.initial_safe_string - 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 - (* 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 - let to_open = - if Env.get_unit_name () = "Pervasives" - then to_open - else "Pervasives" :: to_open - in - List.fold_left open_mod initial to_open + Typemod.initial_env + ~loc:(Location.in_file "ocamldoc command line") + ~safe_string:(Config.safe_string || not !Clflags.unsafe_string) + ~open_pervasives:(Env.get_unit_name () <> "Pervasives") + ~open_implicit_modules:(List.rev !Clflags.open_modules) (** Optionally preprocess a source file *) let preprocess sourcefile = diff --git a/testsuite/tests/typing-shadowing-of-pervasives-submodules/largeFile.ml b/testsuite/tests/typing-shadowing-of-pervasives-submodules/largeFile.ml new file mode 100644 index 000000000000..e9066706584f --- /dev/null +++ b/testsuite/tests/typing-shadowing-of-pervasives-submodules/largeFile.ml @@ -0,0 +1 @@ +let message = "Hello, world!" diff --git a/testsuite/tests/typing-shadowing-of-pervasives-submodules/ocamltests b/testsuite/tests/typing-shadowing-of-pervasives-submodules/ocamltests new file mode 100644 index 000000000000..2ac9cbaeb192 --- /dev/null +++ b/testsuite/tests/typing-shadowing-of-pervasives-submodules/ocamltests @@ -0,0 +1 @@ +redefine_largefile.ml diff --git a/testsuite/tests/typing-shadowing-of-pervasives-submodules/redefine_largefile.ml b/testsuite/tests/typing-shadowing-of-pervasives-submodules/redefine_largefile.ml new file mode 100644 index 000000000000..5d4ac6273cd0 --- /dev/null +++ b/testsuite/tests/typing-shadowing-of-pervasives-submodules/redefine_largefile.ml @@ -0,0 +1,4 @@ +(* TEST + modules = "largeFile.ml" +*) +print_string LargeFile.message diff --git a/testsuite/tests/typing-shadowing-of-pervasives-submodules/redefine_largefile.reference b/testsuite/tests/typing-shadowing-of-pervasives-submodules/redefine_largefile.reference new file mode 100644 index 000000000000..af5626b4a114 --- /dev/null +++ b/testsuite/tests/typing-shadowing-of-pervasives-submodules/redefine_largefile.reference @@ -0,0 +1 @@ +Hello, world! diff --git a/typing/env.ml b/typing/env.ml index 8bf5d8677eab..700c18abdf9a 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -161,7 +161,7 @@ type summary = | Env_modtype of summary * Ident.t * modtype_declaration | Env_class of summary * Ident.t * class_declaration | Env_cltype of summary * Ident.t * class_type_declaration - | Env_open of summary * Path.t + | Env_open of summary * StringSet.t * Path.t | Env_functor_arg of summary * Ident.t | Env_constraints of summary * type_declaration PathMap.t | Env_copy_types of summary * string list @@ -651,9 +651,6 @@ let persistent_structures = let crc_units = Consistbl.create() -module StringSet = - Set.Make(struct type t = string let compare = String.compare end) - let imported_units = ref StringSet.empty let add_import s = @@ -2035,13 +2032,37 @@ let rec add_signature sg env = (* Open a signature path *) -let add_components slot root env0 comps = +let add_components ?filter_modules slot root env0 comps = let add_l w comps env0 = TycompTbl.add_open slot w comps env0 in let add w comps env0 = IdTbl.add_open slot w root comps env0 in + let skipped_modules = ref StringSet.empty in + let filter tbl env0_tbl = + match filter_modules with + | None -> tbl + | Some f -> + Tbl.fold (fun m x acc -> + if f m then + Tbl.add m x acc + else begin + assert + (match IdTbl.find_name m env0_tbl~mark:false with + | (_ : _ * _) -> false + | exception _ -> true); + skipped_modules := StringSet.add m !skipped_modules; + acc + end) + tbl Tbl.empty + in + + let filter_and_add w comps env0 = + let comps = filter comps env0 in + add w comps env0 + in + let constrs = add_l (fun x -> `Constructor x) comps.comp_constrs env0.constrs in @@ -2065,15 +2086,15 @@ let add_components slot root env0 comps = add (fun x -> `Class_type x) comps.comp_cltypes env0.cltypes in let components = - add (fun x -> `Component x) comps.comp_components env0.components + filter_and_add (fun x -> `Component x) comps.comp_components env0.components in let modules = - add (fun x -> `Module x) comps.comp_modules env0.modules + filter_and_add (fun x -> `Module x) comps.comp_modules env0.modules in { env0 with - summary = Env_open(env0.summary, root); + summary = Env_open(env0.summary, !skipped_modules, root); constrs; labels; values; @@ -2085,10 +2106,11 @@ let add_components slot root env0 comps = modules; } -let open_signature slot root env0 = +let open_signature ?filter_modules slot root env0 = match get_components (find_module_descr root env0) with | Functor_comps _ -> None - | Structure_comps comps -> Some (add_components slot root env0 comps) + | Structure_comps comps -> + Some (add_components ?filter_modules slot root env0 comps) (* Open a signature from a file *) @@ -2098,9 +2120,28 @@ let open_pers_signature name env = | Some env -> env | None -> assert false (* a compilation unit cannot refer to a functor *) +let open_signature_of_initially_opened_module root env = + let load_path = !Config.load_path in + let filter_modules m = + match Misc.find_in_path_uncap load_path (m ^ ".cmi") with + | (_ : string) -> false + | exception Not_found -> true + in + open_signature None root env ~filter_modules + +let open_signature_from_env_summary root env ~hidden_submodules = + let filter_modules = + if StringSet.is_empty hidden_submodules then + None + else + Some (fun m -> not (StringSet.mem m hidden_submodules)) + in + open_signature None root env ?filter_modules + let open_signature ?(used_slot = ref false) - ?(loc = Location.none) ?(toplevel = false) ovf root env = + ?(loc = Location.none) ?(toplevel = false) + ovf root env = if not toplevel && ovf = Asttypes.Fresh && not loc.Location.loc_ghost && (Warnings.is_active (Warnings.Unused_open "") || Warnings.is_active (Warnings.Open_shadow_identifier ("", "")) diff --git a/typing/env.mli b/typing/env.mli index e76277ec588c..2301c057c2f9 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -29,7 +29,9 @@ type summary = | Env_modtype of summary * Ident.t * modtype_declaration | Env_class of summary * Ident.t * class_declaration | Env_cltype of summary * Ident.t * class_type_declaration - | Env_open of summary * Path.t + | Env_open of summary * Misc.StringSet.t * Path.t + (** The string set argument of [Env_open] represents a list of module names + to skip, i.e. that won't be imported in the toplevel namespace. *) | Env_functor_arg of summary * Ident.t | Env_constraints of summary * type_declaration PathMap.t | Env_copy_types of summary * string list @@ -162,9 +164,27 @@ val add_signature: signature -> t -> t not a structure. *) val open_signature: ?used_slot:bool ref -> - ?loc:Location.t -> ?toplevel:bool -> Asttypes.override_flag -> Path.t -> + ?loc:Location.t -> ?toplevel:bool -> + Asttypes.override_flag -> Path.t -> t -> t option +(* Similar to [open_signature], except that modules from the load path + have precedence over sub-modules of the opened module. + + For instance, if opening a module [M] with a sub-module [X]: + - if the load path contains a [x.cmi] file, then resolving [X] in the + new environment yields the same result as resolving [X] in the + old environment + - otherwise, in the new environment [X] resolves to [M.X] +*) +val open_signature_of_initially_opened_module: + Path.t -> t -> t option + +(* Similar to [open_signature] except that sub-modules of the opened modules + that are in [hidden_submodules] are not added to the environment. *) +val open_signature_from_env_summary: + Path.t -> t -> hidden_submodules:Misc.StringSet.t -> t option + val open_pers_signature: string -> t -> t (* Insertion by name *) diff --git a/typing/envaux.ml b/typing/envaux.ml index c78f152b666e..caa67f38d69b 100644 --- a/typing/envaux.ml +++ b/typing/envaux.ml @@ -60,10 +60,11 @@ let rec env_from_summary sum subst = | Env_cltype (s, id, desc) -> Env.add_cltype id (Subst.cltype_declaration subst desc) (env_from_summary s subst) - | Env_open(s, path) -> + | Env_open(s, hidden_submodules, path) -> let env = env_from_summary s subst in let path' = Subst.module_path subst path in - begin match Env.open_signature Asttypes.Override path' env with + begin match Env.open_signature_from_env_summary path' env + ~hidden_submodules with | Some env -> env | None -> assert false end diff --git a/typing/typemod.ml b/typing/typemod.ml index e0928156eba7..fd7cd6248517 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -94,6 +94,37 @@ let type_open_ ?used_slot ?toplevel ovf env loc lid = ignore (extract_sig_open env lid.loc md.md_type); assert false +let type_initially_opened_module env = + let loc = Location.in_file "compiler internals" in + let lid = { Asttypes.loc; txt = Longident.Lident "Pervasives" } in + let path = Typetexp.lookup_module ~load:true env lid.loc lid.txt in + match Env.open_signature_of_initially_opened_module 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 initial_env ~loc ~safe_string ~open_pervasives ~open_implicit_modules = + let env = + if safe_string then + Env.initial_safe_string + else + Env.initial_unsafe_string + in + let env = + if open_pervasives then + snd (type_initially_opened_module env) + else + env + 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) + in + List.fold_left open_implicit_module env open_implicit_modules + let type_open ?toplevel env sod = let (path, newenv) = Builtin_attributes.warning_scope sod.popen_attributes diff --git a/typing/typemod.mli b/typing/typemod.mli index fb767db2e39d..f8b81c21d82a 100644 --- a/typing/typemod.mli +++ b/typing/typemod.mli @@ -36,7 +36,8 @@ val transl_signature: val check_nongen_schemes: Env.t -> Types.signature -> unit val type_open_: - ?used_slot:bool ref -> ?toplevel:bool -> Asttypes.override_flag -> + ?used_slot:bool ref -> ?toplevel:bool -> + Asttypes.override_flag -> Env.t -> Location.t -> Longident.t Asttypes.loc -> Path.t * Env.t val modtype_of_package: Env.t -> Location.t -> @@ -52,6 +53,11 @@ val save_signature: val package_units: Env.t -> string list -> string -> string -> Typedtree.module_coercion +(* Should be in Envaux, but it breaks the build of the debugger *) +val initial_env: + loc:Location.t -> safe_string:bool -> open_pervasives:bool -> + open_implicit_modules:string list -> Env.t + type error = Cannot_apply of module_type | Not_included of Includemod.error list