Merge pull request #1880 from voodoos/503-final

Finish upgrade to 5.3

Author: voodoos

src/ocaml/merlin_specific/browse_raw.ml

@@ -360,7 +360,8 @@ let rec of_expression_desc loc = function
            | _, None -> id_fold
            | _, Some e -> of_expression e)
          ls
-  | Texp_match (e, cs, _, _) -> of_expression e ** list_fold of_case cs
+  | Texp_match (e, cs, vs, _) ->
+    of_expression e ** list_fold of_case cs ** list_fold of_case vs
   | Texp_try (e, cs, _) -> of_expression e ** list_fold of_case cs
   | Texp_tuple es | Texp_construct (_, _, es) | Texp_array es ->
     list_fold of_expression es
@@ -560,7 +561,20 @@ let of_node = function
   | Pattern { pat_desc; pat_extra = _ } -> of_pattern_desc pat_desc
   | Expression { exp_desc; exp_extra = _; exp_loc } ->
     of_expression_desc exp_loc exp_desc
-  | Case { c_lhs; c_guard; c_rhs } ->
+  | Case { c_lhs; c_cont = Some (id, vd); c_guard; c_rhs } ->
+    let name = Ident.name id in
+    let cont_pat =
+      { pat_desc = Tpat_var (id, { txt = name; loc = vd.val_loc }, vd.val_uid);
+        pat_loc = vd.val_loc;
+        pat_extra = [];
+        pat_type = vd.val_type;
+        pat_env = c_rhs.exp_env;
+        pat_attributes = []
+      }
+    in
+    of_pattern c_lhs ** of_expression c_rhs ** of_pattern cont_pat
+    ** option_fold of_expression c_guard
+  | Case { c_lhs; c_cont = None; c_guard; c_rhs } ->
     of_pattern c_lhs ** of_expression c_rhs ** option_fold of_expression c_guard
   | Class_expr { cl_desc } -> of_class_expr_desc cl_desc
   | Class_structure { cstr_self; cstr_fields } ->

src/ocaml/typing/ctype.ml

@@ -209,20 +209,23 @@ let create_scope () =
   level
 
 let wrap_end_def f = Misc.try_finally f ~always:end_def
-let wrap_end_def_new_pool f =
-  wrap_end_def (fun _ -> with_new_pool ~level:!current_level f)
 
 (* [with_local_level_gen] handles both the scoping structure of levels
    and automatic generalization through pools (cf. btype.ml) *)
 let with_local_level_gen ~begin_def ~structure ?before_generalize f =
   begin_def ();
   let level = !current_level in
-  let result, pool = wrap_end_def_new_pool f in
-  Option.iter (fun g -> g result) before_generalize;
+  let result, pool =
+    with_new_pool ~level:!current_level begin fun () ->
+      let result = wrap_end_def f in
+      Option.iter (fun g -> g result) before_generalize;
+      result
+    end
+  in
   simple_abbrevs := Mnil;
-  (* Nodes in [pool] were either created by the above call to [f],
-     or they were created before, generalized, and then added to
-     the pool by [update_level].
+  (* Nodes in [pool] were either created by the above calls to [f]
+     and [before_generalize], or they were created before, generalized,
+     and then added to the pool by [update_level].
      In the latter case, their level was already kept for backtracking
      by a call to [set_level] inside [update_level].
      Since backtracking can only go back to a snapshot taken before [f] was

src/ocaml/typing/typecore.ml

@@ -6144,7 +6144,7 @@ and type_cases
     ~type_body:begin
       fun { pc_guard; pc_rhs } pat ~when_env ~ext_env ~cont ~ty_expected
         ~ty_infer ~contains_gadt:_ ->
-        let cont = Option.map (fun (id,_) -> id) cont in
+        (* let cont = Option.map (fun (id,_) -> id) cont in *)
         let guard =
           match pc_guard with
           | None -> None

src/ocaml/typing/typedtree.ml

@@ -159,7 +159,7 @@ and meth =
 and 'k case =
     {
      c_lhs: 'k general_pattern;
-     c_cont: Ident.t option;
+     c_cont: (Ident.t * Types.value_description) option;
      c_guard: expression option;
      c_rhs: expression;
     }

src/ocaml/typing/typedtree.mli

@@ -302,7 +302,7 @@ and meth =
 and 'k case =
     {
      c_lhs: 'k general_pattern;
-     c_cont: Ident.t option;
+     c_cont: (Ident.t * Types.value_description) option;
      c_guard: expression option;
      c_rhs: expression;
     }

tests/test-dirs/type-enclosing/503-effects.t

@@ -0,0 +1,47 @@
+  $ cat >main.ml <<'EOF'
+  > type _ eff += E : unit eff
+  > 
+  > let () =
+  >   Printf.printf "%d\n%!" @@
+  >     match 10 with
+  >     | x -> x
+  >     | effect E, k -> 11
+  > EOF
+
+  $ $MERLIN single errors -filename main.ml <main.ml
+  {
+    "class": "return",
+    "value": [],
+    "notifications": []
+  }
+
+  $ $MERLIN single type-enclosing -position 7:13 \
+  > -filename main.ml <main.ml | jq '.value[0]'
+  {
+    "start": {
+      "line": 7,
+      "col": 13
+    },
+    "end": {
+      "line": 7,
+      "col": 14
+    },
+    "type": "unit eff",
+    "tail": "no"
+  }
+
+The continuation is visible to Merlin
+  $ $MERLIN single type-enclosing -position 7:16 \
+  > -filename main.ml <main.ml | jq '.value[0]'
+  {
+    "start": {
+      "line": 7,
+      "col": 16
+    },
+    "end": {
+      "line": 7,
+      "col": 17
+    },
+    "type": "(%eff, int) continuation",
+    "tail": "no"
+  }

upstream/ocaml_503/base-rev.txt

@@ -1 +1 @@
-630a342bf2b033a1be1c8746cbd34d0c63801ded
+bc5083c1d3b773fc3198355494afd2fb4628ff0e

upstream/ocaml_503/typing/ctype.ml

@@ -192,20 +192,23 @@ let create_scope () =
   level
 
 let wrap_end_def f = Misc.try_finally f ~always:end_def
-let wrap_end_def_new_pool f =
-  wrap_end_def (fun _ -> with_new_pool ~level:!current_level f)
 
 (* [with_local_level_gen] handles both the scoping structure of levels
    and automatic generalization through pools (cf. btype.ml) *)
 let with_local_level_gen ~begin_def ~structure ?before_generalize f =
   begin_def ();
   let level = !current_level in
-  let result, pool = wrap_end_def_new_pool f in
-  Option.iter (fun g -> g result) before_generalize;
+  let result, pool =
+    with_new_pool ~level:!current_level begin fun () ->
+      let result = wrap_end_def f in
+      Option.iter (fun g -> g result) before_generalize;
+      result
+    end
+  in
   simple_abbrevs := Mnil;
-  (* Nodes in [pool] were either created by the above call to [f],
-     or they were created before, generalized, and then added to
-     the pool by [update_level].
+  (* Nodes in [pool] were either created by the above calls to [f]
+     and [before_generalize], or they were created before, generalized,
+     and then added to the pool by [update_level].
      In the latter case, their level was already kept for backtracking
      by a call to [set_level] inside [update_level].
      Since backtracking can only go back to a snapshot taken before [f] was