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/construct.ml

@@ -517,7 +517,10 @@ module Gen = struct
               let arg, name = make_arg env label tyleft in
               let value_description =
                 { val_type = tyleft;
-                  val_kind = Val_reg;
+                  val_kind =
+                    (* CR-someday: this sort should be based on the jkind of [tyleft]. But
+                       this isn't important since this value is just used for printing. *)
+                    Val_reg (Base Value);
                   val_loc = Location.none;
                   val_attributes = [];
                   val_zero_alloc = Zero_alloc.default;

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/syntax_doc.ml

@@ -225,8 +225,12 @@ let get_mode_doc mode =
       Some "The mutable parts of values with this mode can be fully accessed"
     | Comonadic Portability, Nonportable ->
       Some
-        "Values with this mode cannot be sent to other threads, in order to \
-         avoid data races."
+        "Values with this mode cannot be sent to or shared with other threads, \
+         in order to avoid data races."
+    | Comonadic Portability, Shareable ->
+      Some
+        "Values with this mode can be shared with (but not sent to) other \
+         threads without causing data races"
     | Comonadic Portability, Portable ->
       Some
         "Values with this mode can be sent to other threads without causing \
@@ -263,6 +267,8 @@ let get_mode_doc mode =
       Some "Functions with this mode may be executed concurrently."
     | Comonadic Forkable, Unforkable ->
       Some "Functions with this mode cannot be executed concurrently."
+    | Monadic Staticity, Static -> Some "todo"
+    | Monadic Staticity, Dynamic -> Some "todo"
   in
   let doc_url =
     let subpage =
@@ -276,6 +282,7 @@ let get_mode_doc mode =
       | Monadic Visibility -> "modes/intro/"
       | Comonadic Statefulness -> "modes/intro/"
       | Comonadic Forkable -> "modes/intro/"
+      | Monadic Staticity -> "modes/intro/"
     in
     syntax_doc_url Oxcaml subpage
   in

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/analysis/typedtree_utils.ml

@@ -48,7 +48,7 @@ let location_of_declaration ~uid =
   let of_value_binding vb =
     let bound_idents = Typedtree.let_bound_idents_full [ vb ] in
     ListLabels.find_map
-      ~f:(fun (_, loc, _, uid') -> if uid = uid' then Some loc else None)
+      ~f:(fun (_, loc, _, _, uid') -> if uid = uid' then Some loc else None)
       bound_idents
   in
   function

src/ocaml/merlin_specific/tast_helper.ml

@@ -21,7 +21,9 @@ module Pat = struct
       | None -> str.Asttypes.loc
       | Some loc -> loc
     in
-    let sort = Jkind.Sort.new_var () in
+    (* The level we use here isn't important - the constructed type is just used for
+       printing and is never unified. *)
+    let sort = Jkind.Sort.new_var ~level:(Ctype.get_current_level ()) in
     let mode = Mode.Value.newvar () in
     let pat_desc =
       Tpat_var (Ident.create_local str.Asttypes.txt, str, uid, sort, mode)

src/ocaml/parsing/language_extension.ml

@@ -76,6 +76,7 @@ let get_level_ops : type a. a t -> (module Extension_level with type t = a) =
   | Separability -> (module Unit)
   | Let_mutable -> (module Unit)
   | Layout_poly -> (module Maturity)
+  | Runtime_metaprogramming -> (module Unit)
 
 (* We'll do this in a more principled way later. *)
 (* CR layouts: Note that layouts is only "mostly" erasable, because of annoying
@@ -89,7 +90,7 @@ let is_erasable : type a. a t -> bool = function
   | Mode | Unique | Overwriting | Layouts | Layout_poly -> true
   | Comprehensions | Include_functor | Polymorphic_parameters | Immutable_arrays
   | Module_strengthening | SIMD | Labeled_tuples | Small_numbers | Instances
-  | Separability | Let_mutable ->
+  | Separability | Let_mutable | Runtime_metaprogramming ->
     false
 
 let maturity_of_unique_for_drf = Stable
@@ -116,6 +117,7 @@ module Exist_pair = struct
     | Pair (Separability, ()) -> Stable
     | Pair (Let_mutable, ()) -> Stable
     | Pair (Layout_poly, m) -> m
+    | Pair (Runtime_metaprogramming, ()) -> Alpha
 
   let is_erasable : t -> bool = function Pair (ext, _) -> is_erasable ext
 
@@ -131,7 +133,8 @@ module Exist_pair = struct
     | Pair
         ( (( Comprehensions | Include_functor | Polymorphic_parameters
            | Immutable_arrays | Module_strengthening | Labeled_tuples
-           | Instances | Overwriting | Separability | Let_mutable ) as ext),
+           | Instances | Overwriting | Separability | Let_mutable
+           | Runtime_metaprogramming ) as ext),
           _ ) ->
       to_string ext
 
@@ -168,6 +171,7 @@ module Exist_pair = struct
     | "layout_poly" -> Some (Pair (Layout_poly, Stable))
     | "layout_poly_alpha" -> Some (Pair (Layout_poly, Alpha))
     | "layout_poly_beta" -> Some (Pair (Layout_poly, Beta))
+    | "runtime_metaprogramming" -> Some (Pair (Runtime_metaprogramming, ()))
     | _ -> None
 end
 
@@ -191,7 +195,8 @@ let all_extensions =
     Pack Instances;
     Pack Separability;
     Pack Let_mutable;
-    Pack Layout_poly ]
+    Pack Layout_poly;
+    Pack Runtime_metaprogramming ]
 
 (**********************************)
 (* string conversions *)
@@ -233,10 +238,11 @@ let equal_t (type a b) (a : a t) (b : b t) : (a, b) Misc_stdlib.eq option =
   | Separability, Separability -> Some Refl
   | Let_mutable, Let_mutable -> Some Refl
   | Layout_poly, Layout_poly -> Some Refl
+  | Runtime_metaprogramming, Runtime_metaprogramming -> Some Refl
   | ( ( Comprehensions | Mode | Unique | Overwriting | Include_functor
       | Polymorphic_parameters | Immutable_arrays | Module_strengthening
       | Layouts | SIMD | Labeled_tuples | Small_numbers | Instances
-      | Separability | Let_mutable | Layout_poly ),
+      | Separability | Let_mutable | Layout_poly | Runtime_metaprogramming ),
       _ ) ->
     None
 

src/ocaml/parsing/language_extension.mli

@@ -34,6 +34,7 @@ type 'a t = 'a Language_extension_kernel.t =
   | Separability : unit t
   | Let_mutable : unit t
   | Layout_poly : maturity t
+  | Runtime_metaprogramming : unit t
 
 (** Require that an extension is enabled for at least the provided level, or
     else throw an exception at the provided location saying otherwise. *)

src/ocaml/parsing/parsetree.mli

@@ -201,6 +201,9 @@ and core_type_desc =
 
            - As the {{!value_description.pval_type}[pval_type]} field of a
            {!value_description}.
+
+           - As the {!core_type} of a
+           {{!function_param_desc.Pparam_val}[Pparam_val]}.
          *)
   | Ptyp_package of package_type  (** [(module S)]. *)
   | Ptyp_open of Longident.t loc * core_type (** [M.(T)] *)