Upgrade to OCaml 4.14.1 #1557

from voodoos/update-to-4.14.1

Author: voodoos

CHANGES.md

@@ -1,3 +1,10 @@
+merlin 4.8
+==========
+unreleased
+
+  + merlin binary
+    - Update internal typer to match OCaml 4.14.1 release. (#1557)
+
 merlin 4.7
 ==========
 Thu Nov 24 13:31:42 CEST 2022

src/ocaml/typing/env.ml

@@ -104,6 +104,10 @@ let add_label_usage lu usage =
     lu.lu_mutation <- true;
     lu.lu_construct <- true
 
+let is_mutating_label_usage = function
+| Mutation -> true
+| (Projection | Construct | Exported_private | Exported) -> false
+
 let label_usages () =
   {lu_projection = false; lu_mutation = false; lu_construct = false}
 
@@ -2308,6 +2312,14 @@ and add_cltype ?shape id ty env =
 let add_module ?arg ?shape id presence mty env =
   add_module_declaration ~check:false ?arg ?shape id presence (md mty) env
 
+let add_module_lazy ~update_summary id presence mty env =
+  let md = Subst.Lazy.{mdl_type = mty;
+                       mdl_attributes = [];
+                       mdl_loc = Location.none;
+                       mdl_uid = Uid.internal_not_actually_unique}
+  in
+  add_module_declaration_lazy ~update_summary id presence md env
+
 let add_local_type path info env =
   { env with
     local_constraints = Path.Map.add path info env.local_constraints }
@@ -2842,7 +2854,10 @@ let use_cltype ~use ~loc path desc =
 let use_label ~use ~loc usage env lbl =
   if use then begin
     mark_label_description_used usage env lbl;
-    Builtin_attributes.check_alerts loc lbl.lbl_attributes lbl.lbl_name
+    Builtin_attributes.check_alerts loc lbl.lbl_attributes lbl.lbl_name;
+    if is_mutating_label_usage usage then
+      Builtin_attributes.check_deprecated_mutable loc lbl.lbl_attributes
+        lbl.lbl_name
   end
 
 let use_constructor_desc ~use ~loc usage env cstr =

src/ocaml/typing/env.mli

@@ -289,6 +289,8 @@ val add_extension:
   check:bool -> rebind:bool -> Ident.t -> extension_constructor -> t -> t
 val add_module: ?arg:bool -> ?shape:Shape.t ->
   Ident.t -> module_presence -> module_type -> t -> t
+val add_module_lazy: update_summary:bool ->
+  Ident.t -> module_presence -> Subst.Lazy.modtype -> t -> t
 val add_module_declaration: ?arg:bool -> ?shape:Shape.t -> check:bool ->
   Ident.t -> module_presence -> module_declaration -> t -> t
 val add_module_declaration_lazy: update_summary:bool ->

src/ocaml/typing/includemod_errorprinter.ml

@@ -710,7 +710,16 @@ let rec module_type ~expansion_token ~eqmode ~env ~before ~ctx diff =
       functor_params ~expansion_token ~env ~before ~ctx d
   | _ ->
       let inner = if eqmode then eq_module_types else module_types in
-      let next = dwith_context_and_elision ctx inner diff in
+      let next =
+        match diff.symptom with
+        | Mt_core _ ->
+            (* In those cases, the refined error messages for the current error
+               will at most add some minor comments on the current error.
+               It is thus better to avoid eliding the current error message.
+            *)
+            dwith_context ctx (inner diff)
+        | _ -> dwith_context_and_elision ctx inner diff
+      in
       let before = next :: before in
       module_type_symptom ~eqmode ~expansion_token ~env ~before ~ctx
         diff.symptom

src/ocaml/typing/mtype.ml

@@ -46,6 +46,9 @@ let rec strengthen_lazy ~aliasable env mty p =
       MtyL_signature(strengthen_lazy_sig ~aliasable env sg p)
   | MtyL_functor(Named (Some param, arg), res)
     when !Clflags.applicative_functors ->
+      let env =
+        Env.add_module_lazy ~update_summary:false param Mp_present arg env
+      in
       MtyL_functor(Named (Some param, arg),
         strengthen_lazy ~aliasable:false env res (Papply(p, Pident param)))
   | MtyL_functor(Named (None, arg), res)

src/ocaml/typing/printtyp.ml

@@ -1007,7 +1007,10 @@ let reset () =
   reset_except_context ()
 
 let prepare_for_printing tyl =
-  reset_except_context (); List.iter prepare_type tyl
+  reset_except_context ();
+  List.iter prepare_type tyl
+
+let add_type_to_preparation = prepare_type
 
 (* Disabled in classic mode when printing an unification error *)
 let print_labels = ref true
@@ -1416,10 +1419,13 @@ and tree_of_label l =
 
 let constructor ppf c =
   reset_except_context ();
+  prepare_type_constructor_arguments c.cd_args;
+  Option.iter prepare_type c.cd_res;
   !Oprint.out_constr ppf (tree_of_constructor c)
 
 let label ppf l =
   reset_except_context ();
+  prepare_type l.ld_type;
   !Oprint.out_label ppf (tree_of_label l)
 
 let tree_of_type_declaration id decl rs =
@@ -1488,6 +1494,8 @@ let extension_constructor id ppf ext =
 
 let extension_only_constructor id ppf ext =
   reset_except_context ();
+  prepare_type_constructor_arguments ext.ext_args;
+  Option.iter prepare_type ext.ext_ret_type;
   let name = Ident.name id in
   let args, ret =
     extension_constructor_args_and_ret_type_subtree

src/ocaml/typing/printtyp.mli

@@ -112,6 +112,12 @@ val type_expr: formatter -> type_expr -> unit
     Any type variables that are shared between multiple types in the input list
     will be given the same name when printed with [prepared_type_expr]. *)
 val prepare_for_printing: type_expr list -> unit
+
+(** [add_type_to_preparation ty] extend a previous type expression preparation
+    to the type expression [ty]
+*)
+val add_type_to_preparation: type_expr -> unit
+
 val prepared_type_expr: formatter -> type_expr -> unit
 (** The function [prepared_type_expr] is a less-safe but more-flexible version
     of [type_expr] that should only be called on [type_expr]s that have been

src/ocaml/typing/tast_mapper.ml

@@ -461,10 +461,10 @@ let module_type sub x =
 let with_constraint sub = function
   | Twith_type decl -> Twith_type (sub.type_declaration sub decl)
   | Twith_typesubst decl -> Twith_typesubst (sub.type_declaration sub decl)
+  | Twith_modtype mty -> Twith_modtype (sub.module_type sub mty)
+  | Twith_modtypesubst mty -> Twith_modtypesubst (sub.module_type sub mty)
   | Twith_module _
-  | Twith_modsubst _
-  | Twith_modtype _
-  | Twith_modtypesubst _ as d -> d
+  | Twith_modsubst _ as d -> d
 
 let open_description sub od =
   {od with open_env = sub.env sub od.open_env}

src/ocaml/typing/typeclass.ml

@@ -177,6 +177,13 @@ let check_virtual loc env virt kind sign =
       | meths, vars ->
           raise(Error(loc, env, Virtual_class(kind, meths, vars)))
 
+let rec check_virtual_clty loc env virt kind clty =
+  match clty with
+  | Cty_constr(_, _, clty) | Cty_arrow(_, _, clty) ->
+      check_virtual_clty loc env virt kind clty
+  | Cty_signature sign ->
+      check_virtual loc env virt kind sign
+
 (* Return the constructor type associated to a class type *)
 let rec constructor_type constr cty =
   match cty with
@@ -398,6 +405,8 @@ and class_type_aux env virt self_scope scty =
         )       styl params
       in
       let typ = Cty_constr (path, params, clty) in
+      (* Check for unexpected virtual methods *)
+      check_virtual_clty scty.pcty_loc env virt Class_type typ;
       cltyp (Tcty_constr ( path, lid , ctys)) typ
 
   | Pcty_signature pcsig ->
@@ -552,12 +561,11 @@ type first_pass_accummulater =
     concrete_vals : VarSet.t;
     local_meths : MethSet.t;
     local_vals : VarSet.t;
-    vars : Ident.t Vars.t;
-    meths : Ident.t Meths.t; }
+    vars : Ident.t Vars.t; }
 
 let rec class_field_first_pass self_loc cl_num sign self_scope acc cf =
   let { rev_fields; val_env; par_env; concrete_meths; concrete_vals;
-        local_meths; local_vals; vars; meths } = acc
+        local_meths; local_vals; vars } = acc
   in
   let loc = cf.pcf_loc in
   let attributes = cf.pcf_attributes in
@@ -612,13 +620,6 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf =
                   (val_env, par_env, inherited_vars, vars))
                parent_sign.csig_vars (val_env, par_env, [], vars)
            in
-           let meths =
-             Meths.fold
-               (fun label _ meths ->
-                  if Meths.mem label meths then meths
-                  else Meths.add label (Ident.create_local label) meths)
-               parent_sign.csig_meths meths
-           in
            (* Methods available through super *)
            let super_meths =
              MethSet.fold
@@ -641,7 +642,7 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf =
            in
            let rev_fields = field :: rev_fields in
            { acc with rev_fields; val_env; par_env;
-                      concrete_meths; concrete_vals; vars; meths })
+                      concrete_meths; concrete_vals; vars })
   | Pcf_val (label, mut, Cfk_virtual styp) ->
       with_attrs
         (fun () ->
@@ -723,15 +724,11 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf =
            let cty = transl_simple_type val_env false sty in
            let ty = cty.ctyp_type in
            add_method loc val_env label.txt priv Virtual ty sign;
-           let meths =
-             if Meths.mem label.txt meths then meths
-             else Meths.add label.txt (Ident.create_local label.txt) meths
-           in
            let field =
              Virtual_method { label; priv; cty; loc; attributes }
            in
            let rev_fields = field :: rev_fields in
-           { acc with rev_fields; meths })
+           { acc with rev_fields })
 
   | Pcf_method (label, priv, Cfk_concrete (override, expr)) ->
       with_attrs
@@ -785,10 +782,6 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf =
                raise(Error(loc, val_env,
                            Field_type_mismatch ("method", label.txt, err)))
            end;
-           let meths =
-             if Meths.mem label.txt meths then meths
-             else Meths.add label.txt (Ident.create_local label.txt) meths
-           in
            let sdefinition = make_method self_loc cl_num expr in
            let warning_state = Warnings.backup () in
            let field =
@@ -799,7 +792,7 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf =
            let rev_fields = field :: rev_fields in
            let concrete_meths = MethSet.add label.txt concrete_meths in
            let local_meths = MethSet.add label.txt local_meths in
-           { acc with rev_fields; concrete_meths; local_meths; meths })
+           { acc with rev_fields; concrete_meths; local_meths })
 
   | Pcf_constraint (sty1, sty2) ->
       with_attrs
@@ -837,11 +830,10 @@ and class_fields_first_pass self_loc cl_num sign self_scope
   let local_meths = MethSet.empty in
   let local_vals = VarSet.empty in
   let vars = Vars.empty in
-  let meths = Meths.empty in
   let init_acc =
     { rev_fields; val_env; par_env;
       concrete_meths; concrete_vals;
-      local_meths; local_vals; vars; meths }
+      local_meths; local_vals; vars }
   in
   let acc =
     Builtin_attributes.warning_scope []
@@ -850,7 +842,7 @@ and class_fields_first_pass self_loc cl_num sign self_scope
           (class_field_first_pass self_loc cl_num sign self_scope)
           init_acc cfs)
   in
-  List.rev acc.rev_fields, acc.vars, acc.meths
+  List.rev acc.rev_fields, acc.vars
 
 and class_field_second_pass cl_num sign met_env field =
   let mkcf desc loc attrs =
@@ -1003,7 +995,7 @@ and class_structure cl_num virt self_scope final val_env met_env loc
   end;
 
   (* Typing of class fields *)
-  let (fields, vars, meths) =
+  let (fields, vars) =
     class_fields_first_pass self_loc cl_num sign self_scope
            val_env par_env str
   in
@@ -1016,6 +1008,13 @@ and class_structure cl_num virt self_scope final val_env met_env loc
   update_class_signature loc val_env
     ~warn_implicit_public:false virt kind sign;
 
+  let meths =
+    Meths.fold
+      (fun label _ meths ->
+         Meths.add label (Ident.create_local label) meths)
+      sign.csig_meths Meths.empty
+  in
+
   (* Close the signature if it is final *)
   begin match final with
   | Not_final -> ()
@@ -1087,6 +1086,8 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl =
            try Ctype.unify val_env ty' ty with Ctype.Unify err ->
              raise(Error(cty'.ctyp_loc, val_env, Parameter_mismatch err)))
         tyl params;
+      (* Check for unexpected virtual methods *)
+      check_virtual_clty scl.pcl_loc val_env virt Class clty';
       let cl =
         rc {cl_desc = Tcl_ident (path, lid, tyl);
             cl_loc = scl.pcl_loc;
@@ -1972,7 +1973,6 @@ let report_error env ppf = function
         (function ppf ->
            fprintf ppf "but is expected to have type")
   | Unexpected_field (ty, lab) ->
-      Printtyp.prepare_for_printing [ty];
       fprintf ppf
         "@[@[<2>This object is expected to have type :@ %a@]\
          @ This type does not have a method %s."
@@ -2057,12 +2057,12 @@ let report_error env ppf = function
       Includeclass.report_error Type ppf error
   | Unbound_val lab ->
       fprintf ppf "Unbound instance variable %s" lab
-  | Unbound_type_var (printer, (ty0, real, lab, ty)) ->
-      let ty1 =
-        if real then ty0 else Btype.newgenty(Tobject(ty0, ref None))
-      in
-      Printtyp.prepare_for_printing [ty; ty1];
-      let print_reason ppf (ty0, lab, ty) =
+  | Unbound_type_var (printer, reason) ->
+      let print_reason ppf (ty0, real, lab, ty) =
+        let ty1 =
+          if real then ty0 else Btype.newgenty(Tobject(ty0, ref None)) in
+        Printtyp.add_type_to_preparation ty;
+        Printtyp.add_type_to_preparation ty1;
         fprintf ppf
           "The method %s@ has type@;<1 2>%a@ where@ %a@ is unbound"
           lab
@@ -2072,7 +2072,7 @@ let report_error env ppf = function
       fprintf ppf
         "@[<v>@[Some type variables are unbound in this type:@;<1 2>%t@]@ \
               @[%a@]@]"
-       printer print_reason (ty0, lab, ty)
+       printer print_reason reason
   | Non_generalizable_class (id, clty) ->
       fprintf ppf
         "@[The type of this class,@ %a,@ \

src/ocaml/typing/typedecl.ml

@@ -1338,7 +1338,7 @@ let rec parse_native_repr_attributes env core_type ty ~global_repr =
       parse_native_repr_attributes env ct2 t2 ~global_repr
     in
     (repr_arg :: repr_args, repr_res)
-  | Ptyp_poly (_, t), _, _ ->
+  | (Ptyp_poly (_, t) | Ptyp_alias (t, _)), _, _ ->
      parse_native_repr_attributes env t ty ~global_repr
   | Ptyp_arrow _, _, _ | _, Tarrow _, _ -> assert false
   | _ -> ([], make_native_repr env core_type ty ~global_repr)