Merge 5.2.0minus-24

src/analysis/completion.ml

@@ -37,8 +37,8 @@ let { Logger.log } = Logger.for_section "Completion"
 
 type raw_info =
   [ `Constructor of Types.constructor_description
-  | `Modtype of Types.module_type
-  | `Modtype_declaration of Ident.t * Types.modtype_declaration
+  | `Modtype of Subst.Lazy.module_type
+  | `Modtype_declaration of Ident.t * Subst.Lazy.modtype_declaration
   | `None
   | `String of string
   | `Type_declaration of Ident.t * Types.type_declaration
@@ -47,8 +47,11 @@ type raw_info =
 
 let raw_info_printer : raw_info -> _ = function
   | `Constructor c -> `Print (Out_type (Browse_misc.print_constructor c))
-  | `Modtype mt -> `Print (Out_module_type (Printtyp.tree_of_modtype mt))
+  | `Modtype mt ->
+    let mt = Subst.Lazy.force_modtype mt in
+    `Print (Out_module_type (Printtyp.tree_of_modtype mt))
   | `Modtype_declaration (id, mtd) ->
+    let mtd = Subst.Lazy.force_modtype_decl mtd in
     `Print (Out_sig_item (Printtyp.tree_of_modtype_declaration id mtd))
   | `None -> `String ""
   | `String s -> `String s
@@ -315,8 +318,8 @@ let get_candidates ?get_doc ?target_type ?prefix_path ~prefix kind ~validate env
   let val_attributes v = v.Subst.Lazy.val_attributes in
   let type_attributes t = t.Types.type_attributes in
   let lbl_attributes l = l.Types.lbl_attributes in
-  let mtd_attributes t = t.Types.mtd_attributes in
-  let md_attributes t = t.Types.md_attributes in
+  let mtd_attributes t = t.Subst.Lazy.mtd_attributes in
+  let md_attributes t = t.Subst.Lazy.md_attributes in
   let make_candidate ~attrs ~exact name ?loc ?path ty =
     make_candidate ~get_doc ~prefix_path ~attrs ~exact name ?loc ?path ty
   in
@@ -459,18 +462,18 @@ let get_candidates ?get_doc ?target_type ?prefix_path ~prefix kind ~validate env
               :: candidates)
           prefix_path env []
       | `Modules ->
-        Env.fold_modules
+        Env.fold_modules_lazy
           (fun name path v candidates ->
             let attrs = md_attributes v in
-            let v = v.Types.md_type in
+            let v = v.Subst.Lazy.md_type in
             if not @@ validate `Uident `Mod name then candidates
             else
               make_weighted_candidate ~exact:(name = prefix) name ~path (`Mod v)
                 ~attrs
               :: candidates)
           prefix_path env []
       | `Modules_type ->
-        Env.fold_modtypes
+        Env.fold_modtypes_lazy
           (fun name path v candidates ->
             if not @@ validate `Uident `Mod name then candidates
             else
@@ -683,7 +686,7 @@ let complete_prefix ?get_doc ?target_type ?(kinds = []) ~keywords ~prefix
   with Not_found -> []
 
 (* Propose completion from a particular node *)
-let branch_complete buffer ?get_doc ?target_type ?kinds ~keywords prefix =
+let branch_complete buffer ?get_doc ?target_type ?kinds ~keywords prefix : _ -> raw_info raw_entry list =
   function
   | [] -> []
   | (env, node) :: branch -> (

src/analysis/completion.mli

@@ -32,8 +32,8 @@ open Query_protocol
 
 type raw_info =
   [ `Constructor of Types.constructor_description
-  | `Modtype of Types.module_type
-  | `Modtype_declaration of Ident.t * Types.modtype_declaration
+  | `Modtype of Subst.Lazy.module_type
+  | `Modtype_declaration of Ident.t * Subst.Lazy.modtype_declaration
   | `None
   | `String of string
   | `Type_declaration of Ident.t * Types.type_declaration

src/analysis/env_lookup.ml

@@ -113,12 +113,12 @@ let by_longident (nss : Namespace.inferred list) ident env =
             raise (Found (path, Constructor, cd.cstr_uid, loc))
           | `Mod ->
             log ~title:"lookup" "lookup in module namespace";
-            let path, md = Env.find_module_by_name ident env in
-            raise (Found (path, Module, md.md_uid, md.Types.md_loc))
+            let path, md = Env.find_module_by_name_lazy ident env in
+            raise (Found (path, Module, md.md_uid, md.md_loc))
           | `Modtype ->
             log ~title:"lookup" "lookup in module type namespace";
-            let path, mtd = Env.find_modtype_by_name ident env in
-            raise (Found (path, Module_type, mtd.mtd_uid, mtd.Types.mtd_loc))
+            let path, mtd = Env.find_modtype_by_name_lazy ident env in
+            raise (Found (path, Module_type, mtd.mtd_uid, mtd.mtd_loc))
           | `Type ->
             log ~title:"lookup" "lookup in type namespace";
             let path, typ_decl = Env.find_type_by_name ident env in

src/analysis/polarity_search.ml

@@ -115,7 +115,7 @@ let directories ~global_modules env =
   List.fold_left
     ~f:(fun l name ->
       let lident = Longident.Lident name in
-      match Env.find_module_by_name lident env with
+      match Env.find_module_by_name_lazy lident env with
       | exception _ -> l
       | _ -> Trie (name, lident, lazy (explore lident env)) :: l)
     ~init:[] global_modules
@@ -138,7 +138,7 @@ let execute_query query env dirs =
   in
   let rec recurse acc (Trie (_, dir, children)) =
     match
-      ignore (Env.find_module_by_name dir env);
+      ignore (Env.find_module_by_name_lazy dir env);
       Lazy.force children
     with
     | children ->

src/analysis/type_search.ml

@@ -116,7 +116,7 @@ let compute_values query env lident acc =
 
 let values_from_module query env lident acc =
   let rec aux acc lident =
-    match Env.find_module_by_name lident env with
+    match Env.find_module_by_name_lazy lident env with
     | exception _ -> acc
     | _ ->
       let acc = compute_values query env (Some lident) acc in

src/analysis/type_utils.ml

@@ -59,8 +59,8 @@ let parse_longident lid =
   with Parser_raw.Error -> None
 
 let lookup_module name env =
-  let path, md = Env.find_module_by_name name env in
-  (path, md.Types.md_type, md.Types.md_attributes)
+  let path, md = Env.find_module_by_name_lazy name env in
+  (path, md.md_type, md.md_attributes)
 
 let verbosity = ref Verbosity.default
 
@@ -155,22 +155,22 @@ module Printtyp = struct
     let_ref verbosity v (fun () -> wrap_printing_env env f)
 end
 
-let si_modtype_opt = function
-  | Types.Sig_modtype (_, m, _) -> m.mtd_type
-  | Types.Sig_module (_, _, m, _, _) -> Some m.md_type
+let si_modtype_opt : Subst.Lazy.signature_item -> _ = function
+  | Sig_modtype (_, m, _) -> m.mtd_type
+  | Sig_module (_, _, m, _, _) -> Some m.md_type
   | _ -> None
 
 (* Check if module is smaller (= has less definition, counting nested ones)
  * than a particular threshold. Return (Some n) if module has size n, or None
  * otherwise (module is bigger than threshold).
  * Used to skip printing big modules in completion. *)
-let rec mod_smallerthan n m =
+let rec mod_smallerthan n (m : Subst.Lazy.module_type) =
   if n < 0 then None
   else
-    let open Types in
     match m with
     | Mty_ident _ -> Some 1
     | Mty_signature s -> begin
+      let s = Subst.Lazy.force_signature_once s in
       match List.length_lessthan n s with
       | None -> None
       | Some _ ->
@@ -190,17 +190,15 @@ let rec mod_smallerthan n m =
                 | Some n', _ -> Some (succ n')
             end
     end
-    | Mty_functor _ ->
-      let m1, m2 = unpack_functor m in
-      begin
-        match (mod_smallerthan n m2, m1) with
-        | None, _ -> None
-        | result, Unit -> result
-        | Some n1, Named (_, mt) -> (
-          match mod_smallerthan (n - n1) mt with
-          | None -> None
-          | Some n2 -> Some (n1 + n2))
-      end
+    | Mty_functor (m1, m2) -> begin
+      match (mod_smallerthan n m2, m1) with
+      | None, _ -> None
+      | result, Unit -> result
+      | Some n1, Named (_, mt) -> (
+        match mod_smallerthan (n - n1) mt with
+        | None -> None
+        | Some n2 -> Some (n1 + n2))
+    end
     | _ -> Some 1
 
 let print_short_modtype verbosity env ppf md =
@@ -209,7 +207,9 @@ let print_short_modtype verbosity env ppf md =
   match mod_smallerthan 1000 md with
   | None when verbosity = 0 ->
     Format.pp_print_string ppf "(* large signature, repeat to confirm *)"
-  | _ -> Printtyp.modtype env ppf md
+  | _ ->
+    let md = Subst.Lazy.force_modtype md in
+    Printtyp.modtype env ppf md
 
 let print_type_with_decl ~verbosity env ppf typ =
   match verbosity with
@@ -260,13 +260,13 @@ let print_type ppf verbosity env lid =
     end
 
 let print_modtype ppf verbosity env lid =
-  let _p, mtd = Env.find_modtype_by_name lid.Asttypes.txt env in
+  let _p, mtd = Env.find_modtype_by_name_lazy lid.Asttypes.txt env in
   match mtd.mtd_type with
   | Some mt -> print_short_modtype verbosity env ppf mt
   | None -> Format.pp_print_string ppf "(* abstract module *)"
 
 let print_modpath ppf verbosity env lid =
-  let _path, md = Env.find_module_by_name lid.Asttypes.txt env in
+  let _path, md = Env.find_module_by_name_lazy lid.Asttypes.txt env in
   print_short_modtype verbosity env ppf md.md_type
 
 let print_cstr_desc ppf cstr_desc =

src/analysis/type_utils.mli

@@ -50,7 +50,7 @@ end
     than a particular threshold. Return (Some n) if module has size n, or None
     otherwise (module is bigger than threshold).
     Used to skip printing big modules in completion. *)
-val mod_smallerthan : int -> Types.module_type -> int option
+val mod_smallerthan : int -> Subst.Lazy.module_type -> int option
 
 (** [type_in_env env ppf input] parses [input] and prints its type on [ppf].
     Returning true if it printed a type, false otherwise. *)
@@ -76,7 +76,7 @@ val print_type_with_decl :
 (** [lookup_module] is a fancier version of [Env.lookup_module] that also
     returns the module type. *)
 val lookup_module :
-  Longident.t -> Env.t -> Path.t * Types.module_type * Parsetree.attributes
+  Longident.t -> Env.t -> Path.t * Subst.Lazy.module_type * Parsetree.attributes
 
 (** [read_doc_attributes] looks for a docstring in an attribute list. *)
 val read_doc_attributes : Parsetree.attributes -> (string * Location.t) option

src/ocaml/typing/env.ml

@@ -4625,18 +4625,15 @@ let find_all_simple_list proj1 proj2 f lid env acc =
           acc
       end
 
-let fold_modules f lid env acc =
+let fold_modules_lazy f lid env acc =
   match lid with
   | None ->
       IdTbl.fold_name wrap_module
         (fun name (p, entry) acc ->
            match entry with
            | Mod_unbound _ -> acc
            | Mod_local (mda, _) ->
-               let md =
-                 Subst.Lazy.force_module_decl mda.mda_declaration
-               in
-               f name p md acc
+               f name p mda.mda_declaration acc
            | Mod_persistent ->
                (* CR lmaurer: Setting instance args to [] here isn't right. We
                   really should have [IdTbl.fold_name] provide the whole ident
@@ -4647,10 +4644,7 @@ let fold_modules f lid env acc =
                match Persistent_env.find_in_cache !persistent_env modname with
                | None -> acc
                | Some mda ->
-                   let md =
-                     Subst.Lazy.force_module_decl mda.mda_declaration
-                   in
-                   f name p md acc)
+                   f name p mda.mda_declaration acc)
         env.modules
         acc
   | Some l ->
@@ -4662,16 +4656,20 @@ let fold_modules f lid env acc =
       | Structure_comps c ->
           NameMap.fold
             (fun s mda acc ->
-               let md =
-                 Subst.Lazy.force_module_decl mda.mda_declaration
-               in
-               f s (Pdot (p, s)) md acc)
+               f s (Pdot (p, s)) mda.mda_declaration acc)
             c.comp_modules
             acc
       | Functor_comps _ ->
           acc
       end
 
+let fold_modules f lid env acc =
+  fold_modules_lazy
+    (fun name path md acc ->
+      let md = Subst.Lazy.force_module_decl md in
+      f name path md acc)
+    lid env acc
+
 let fold_values f =
   find_all wrap_value (fun env -> env.values) (fun sc -> sc.comp_values)
     (fun k p ve acc ->
@@ -4693,8 +4691,8 @@ and fold_types f =
   find_all wrap_identity
     (fun env -> env.types) (fun sc -> sc.comp_types)
     (fun k p tda acc -> f k p tda.tda_declaration acc)
-and fold_modtypes f =
-  let f l path data acc = f l path (Subst.Lazy.force_modtype_decl data) acc in
+and fold_modtypes_lazy f =
+  let f l path data acc = f l path data acc in
   find_all wrap_identity
     (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes)
     (fun k p mta acc -> f k p mta.mtda_declaration acc)
@@ -4706,6 +4704,9 @@ and fold_cltypes f =
     (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes)
     (fun k p cltda acc -> f k p cltda.cltda_declaration acc)
 
+let fold_modtypes f =
+  fold_modtypes_lazy (fun k p mdty acc -> f k p (Subst.Lazy.force_modtype_decl mdty) acc)
+
 let filter_non_loaded_persistent f env =
   let to_remove =
     IdTbl.fold_name wrap_module

src/ocaml/typing/env.mli

@@ -752,3 +752,10 @@ val fold_all_labels: 'a fold_all_labels_f -> Longident.t option -> t -> 'a -> 'a
 
 val print_with_quote_promote :
   Format.formatter -> (string * stage * stage) -> unit
+
+val fold_modules_lazy:
+  (string -> Path.t -> Subst.Lazy.module_declaration -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a
+val fold_modtypes_lazy:
+  (string -> Path.t -> Subst.Lazy.modtype_declaration -> 'a -> 'a) ->
+  Longident.t option -> t -> 'a -> 'a

src/ocaml/typing/typedtree.ml

@@ -1393,16 +1393,6 @@ let mode_without_locks_exn = function
 
 (* Merlin specific *)
 
-let unpack_functor_me me =
-  match me.mod_desc with
-  | Tmod_functor (fp, mty) -> fp, mty
-  | _ -> invalid_arg "Typedtree.unpack_functor_me (merlin)"
-
-let unpack_functor_mty mty =
-  match mty.mty_desc with
-  | Tmty_functor (fp, mty) -> fp, mty
-  | _ -> invalid_arg "Typedtree.unpack_functor_mty (merlin)"
-
 let rec fold_antiquote_exp f  acc exp =
   match exp.exp_desc with
   | Texp_ident _ | Texp_constant _ -> acc

src/ocaml/typing/typedtree.mli

@@ -1385,9 +1385,6 @@ val mode_without_locks_exn : mode_with_locks -> Mode.Value.l
 
 (* Merlin specific *)
 
-val unpack_functor_me : module_expr -> functor_parameter * module_expr
-val unpack_functor_mty : module_type -> functor_parameter * module_type
-
 (** Fold over the antiquotations in an expression. This function defines the
     evaluation order of antiquotations. *)
 val fold_antiquote_exp : ('a -> expression -> 'a) -> 'a -> expression -> 'a

src/ocaml/typing/types.ml

@@ -1914,7 +1914,3 @@ let is_valid (changes, _old) =
 
 let on_backtrack f =
   log_change (Cfun f)
-
-let unpack_functor = function
-  | Mty_functor (fp, mty) -> fp, mty
-  | _ -> invalid_arg "Types.unpack_functor (merlin)"

src/ocaml/typing/types.mli

@@ -1288,4 +1288,3 @@ val on_backtrack: (unit -> unit) -> unit
    Used to estimate the "cost" of unification. *)
 val linked_variables: unit -> int
 
-val unpack_functor : module_type -> functor_parameter * module_type