Upgrade Merlin's vendored compiler

Author: voodoos

src/ocaml/parsing/pprintast.ml

@@ -1761,6 +1761,12 @@ let prepare_error err =
         "broken invariant in parsetree: %s" s
   | Invalid_package_type (loc, s) ->
       Location.errorf ~source ~loc "invalid package type: %s" s
+  | Removed_string_set loc ->
+      Location.errorf ~loc
+        "Syntax error: strings are immutable, there is no assignment \
+          syntax for them.\n\
+          Hint: Mutable sequences of bytes are available in the Bytes module.\n\
+          Hint: Did you mean to use 'Bytes.set'?"
 
 let () =
   Location.register_error_of_exn

src/ocaml/parsing/syntaxerr.ml

@@ -24,6 +24,7 @@ type error =
   | Other of Location.t
   | Ill_formed_ast of Location.t * string
   | Invalid_package_type of Location.t * string
+  | Removed_string_set of Location.t
 
 exception Error of error
 exception Escape_error
@@ -36,7 +37,8 @@ let location_of_error = function
   | Not_expecting (l, _)
   | Ill_formed_ast (l, _)
   | Invalid_package_type (l, _)
-  | Expecting (l, _) -> l
+  | Expecting (l, _)
+  | Removed_string_set l -> l
 
 
 let ill_formed_ast loc s =

src/ocaml/parsing/syntaxerr.mli

@@ -29,6 +29,7 @@ type error =
   | Other of Location.t
   | Ill_formed_ast of Location.t * string
   | Invalid_package_type of Location.t * string
+  | Removed_string_set of Location.t
 
 exception Error of error
 exception Escape_error

src/ocaml/preprocess/parser_raw.mly

@@ -227,6 +227,8 @@ let mkpat_opt_constraint ~loc p = function
 (*let syntax_error () =
   raise Syntaxerr.Escape_error*)
 
+let removed_string_set loc =
+  raise_error Syntaxerr.(Error(Syntaxerr.Removed_string_set(make_loc loc)))
 
 (* Using the function [not_expecting] in a semantic action means that this
    syntactic form is recognized by the parser but is in fact incorrect. This
@@ -312,7 +314,9 @@ let builtin_arraylike_name loc _ ~assign paren_kind n =
   let opname = if !Clflags.fast then "unsafe_" ^ opname else opname in
   let prefix = match paren_kind with
     | Paren -> Lident "Array"
-    | Bracket -> Lident "String"
+    | Bracket ->
+        if assign then removed_string_set loc;
+        Lident "String"
     | Brace ->
        let submodule_name = match n with
          | One -> "Array1"

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}
 
@@ -2842,7 +2846,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/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/predef.ml

@@ -96,9 +96,6 @@ and ident_sys_blocked_io = ident_create "Sys_blocked_io"
 and ident_assert_failure = ident_create "Assert_failure"
 and ident_undefined_recursive_module =
         ident_create "Undefined_recursive_module"
-and ident_continuation_already_taken =
-        ident_create "Continuation_already_taken"
-and ident_unhandled = ident_create "Unhandled"
 
 let all_predef_exns = [
   ident_match_failure;
@@ -113,8 +110,6 @@ let all_predef_exns = [
   ident_sys_blocked_io;
   ident_assert_failure;
   ident_undefined_recursive_module;
-  ident_continuation_already_taken;
-  ident_unhandled;
 ]
 
 let path_match_failure = Pident ident_match_failure
@@ -237,7 +232,6 @@ let build_initial_env add_type add_extension empty_env =
   (* Predefined exceptions - alphabetical order *)
   |> add_extension ident_assert_failure
        [newgenty (Ttuple[type_string; type_int; type_int])]
-  |> add_extension ident_continuation_already_taken []
   |> add_extension ident_division_by_zero []
   |> add_extension ident_end_of_file []
   |> add_extension ident_failure [type_string]
@@ -251,7 +245,6 @@ let build_initial_env add_type add_extension empty_env =
   |> add_extension ident_sys_error [type_string]
   |> add_extension ident_undefined_recursive_module
        [newgenty (Ttuple[type_string; type_int; type_int])]
-  |> add_extension ident_unhandled []
 
 let builtin_values =
   List.map (fun id -> (Ident.name id, id)) all_predef_exns

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}