Allow compilation units to shadow sub-modules of Pervasives (#1513)

12 files changed, 136 insertions, 53 deletions

diff --git a/Changes b/Changes
index e986570c90..814a3b2055 100644
--- a/Changes
+++ b/Changes
@@ -29,6 +29,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 a0839f34ca..08dc670d3d 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 1393d571c1..13c128a4db 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 0000000000..e906670658
--- /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 0000000000..2ac9cbaeb1
--- /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 0000000000..5d4ac6273c
--- /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 0000000000..af5626b4a1
--- /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 8bf5d8677e..700c18abdf 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 e76277ec58..2301c057c2 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 c78f152b66..caa67f38d6 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 e0928156eb..fd7cd62485 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 fb767db2e3..f8b81c21d8 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