Allow destruction in let bindings' pattern

CHANGES.md

@@ -1,3 +1,9 @@
+unreleased
+==========
+
+  + merlin library
+    - destruct: allow to destruct let-bindings's patterns (#2117)
+
 merlin 5.8.1
 ============
 Fri Jul 31 11:31:42 CEST 2026

src/analysis/destruct.ml

@@ -213,6 +213,7 @@ let rec get_match = function
     | Case _ | Pattern _ ->
       (* We are still in the same branch, going up. *)
       get_match parents
+    | Value_binding { vb_expr; _ } -> (vb_expr, vb_expr.exp_type)
     | Expression m -> (
       match m.Typedtree.exp_desc with
       | Typedtree.Texp_match (e, _, _, _) -> (m, e.exp_type)
@@ -248,6 +249,9 @@ let rec get_match = function
       let s = Mbrowse.print_node () parent in
       raise (Not_allowed s))
 
+let collect_every_pattern_for_let_binding vb =
+  (vb.Typedtree.vb_pat.pat_loc, [ vb.vb_pat ])
+
 let collect_every_pattern_for_expression parent =
   let patterns =
     Mbrowse.fold_node
@@ -326,6 +330,7 @@ let rec get_every_pattern loc = function
     | Expression _ ->
       (* We are on the right node *)
       collect_every_pattern_for_expression parent
+    | Value_binding vb -> collect_every_pattern_for_let_binding vb
     | _ ->
       (* We were not in a match *)
       let s = Mbrowse.print_node () parent in

tests/test-dirs/destruct/errors.t

@@ -3,7 +3,7 @@ Test 1
   $ echo "let () = ()" | $MERLIN single case-analysis -start 1:4 -end 1:4 -filename stacktrace.ml | grep -E -v "Raised|Called|Re-raised"
   {
     "class": "error",
-    "value": "Destruct not allowed on value_binding",
+    "value": "Nothing to do",
     "notifications": []
   }
 

tests/test-dirs/destruct/issue596.t

@@ -2,7 +2,19 @@
   > let a = 1 in a + 1 ;;
   > EOF
   {
-    "class": "error",
-    "value": "Destruct not allowed on value_binding",
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 4
+        },
+        "end": {
+          "line": 1,
+          "col": 5
+        }
+      },
+      "0 | _"
+    ],
     "notifications": []
   }

tests/test-dirs/destruct/let-bindings.t

@@ -0,0 +1,166 @@
+Here we test destruction on patterns lhs of value bindings.
+
+  $ cat > letbindings.ml <<EOF
+  > type t = { x : int option ; y : float}
+  > let record = {x = None; y = 2.}
+  > type u = A | B of t
+  > let variant = A
+  > 
+  > let a =
+  >   let _ = record in
+  >   ()
+  > 
+  > let b =
+  >   let _ = variant in
+  >   ()
+  > 
+  > let b =
+  >   let A | B _ = variant in
+  >   ()
+  > 
+  > let b =
+  >   let {x = _; y} = record in
+  >   ()
+  > EOF
+
+Trying to destruct a pattern that's the lhs of a value binding whose rhs is a
+record:
+
+  $ $MERLIN single case-analysis -start 7:7 -end 7:7 -filename letbindings.ml < letbindings.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 7,
+          "col": 6
+        },
+        "end": {
+          "line": 7,
+          "col": 7
+        }
+      },
+      "{ x; y }"
+    ],
+    "notifications": []
+  }
+
+Trying to destruct a pattern that's the lhs of a value binding whose rhs is a
+variant:
+
+  $ $MERLIN single case-analysis -start 11:7 -end 11:7 -filename letbindings.ml < letbindings.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 11,
+          "col": 6
+        },
+        "end": {
+          "line": 11,
+          "col": 7
+        }
+      },
+      "A | B _"
+    ],
+    "notifications": []
+  }
+
+Destructing a **subcase** of a pattern that's the lhs of a value binding whose
+rhs is a variant.
+Note that, internally this is stored in the typedtree as a match (to check for
+exhaustiveness of pattern matching), so we are not really checking anything
+about let bindings.
+
+  $ $MERLIN single case-analysis -start 15:13 -end 15:13 -filename letbindings.ml < letbindings.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 15,
+          "col": 12
+        },
+        "end": {
+          "line": 15,
+          "col": 13
+        }
+      },
+      "{ x; y }"
+    ],
+    "notifications": []
+  }
+
+Destructing a **subcase** of a pattern that's the lhs of a value binding whose
+rhs is a record
+
+  $ $MERLIN single case-analysis -start 19:12 -end 19:12 -filename letbindings.ml < letbindings.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 19,
+          "col": 6
+        },
+        "end": {
+          "line": 19,
+          "col": 16
+        }
+      },
+      "{ x = None; y } | { x = Some _; y }"
+    ],
+    "notifications": []
+  }
+
+Now, for completeness we test toplevel bindings
+
+  $ cat > letbindings_toplevel.ml <<EOF
+  > type t = { x : int option ; y : float}
+  > let record = {x = None; y = 2.}
+  > type u = A | B of t
+  > let variant = A
+  > 
+  > let _ = record
+  > 
+  > let _ = variant
+  > EOF
+
+  $ $MERLIN single case-analysis -start 6:4 -end 6:4 -filename letbindings_toplevel.ml < letbindings_toplevel.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 6,
+          "col": 4
+        },
+        "end": {
+          "line": 6,
+          "col": 5
+        }
+      },
+      "{ x; y }"
+    ],
+    "notifications": []
+  }
+
+  $ $MERLIN single case-analysis -start 8:4 -end 8:4 -filename letbindings_toplevel.ml < letbindings_toplevel.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 8,
+          "col": 4
+        },
+        "end": {
+          "line": 8,
+          "col": 5
+        }
+      },
+      "A | B _"
+    ],
+    "notifications": []
+  }