[B] ocaml#1800 Refinement in the presence of optional arguments

CHANGES.md

@@ -5,6 +5,7 @@ unreleased
     - A new `WRAPPING_PREFIX` configuration directive that can be used to tell Merlin
       what to append to the current unit name in the presence of wrapping (#1788)
     - Add `-unboxed-types` and `-no-unboxed-types` as ocaml ignored flags (#1795, fixes #1794)
+    - destruct: Refinement in the presence of optional arguments (#1800 fixes #1770)
   + editor modes
     - vim: fix python-3.12 syntax warnings in merlin.py (#1798)
     - vim: Dead code / doc removal for previously deleted MerlinPhrase command (#1804)

src/analysis/destruct.ml

@@ -500,9 +500,44 @@ let print_pretty ?punned_field config source subject =
   | Some label ->
     label.Types.lbl_name ^ " = " ^ result
 
+let need_recover_labeled_args = function
+  | Parsetree.Pexp_construct ({loc; txt = Longident.Lident ctor}, Some e) ->
+    (* If the internal construction is ghosted, then the expression must be
+       re-labelled. *)
+    if String.equal "Some" ctor && loc.loc_ghost then Some e else None
+  | _ -> None
+
+let remove_non_applied_optional_args (Parsetree.{ pexp_desc; _} as base_expr) =
+  (* Fix the behaviour described here
+     https://github.com/ocaml/merlin/issues/1770 *)
+  match pexp_desc with
+  | Parsetree.Pexp_apply (expr, args) ->
+    let args = List.concat_map ~f:(fun (label, expr) ->
+      match label with
+      | Asttypes.Optional str ->
+        (* If an optional parameter is not applied, its location is assumed to
+           be ghost, and the parameter should not be generated. *)
+        let loc = expr.Parsetree.pexp_loc in
+        if loc.loc_ghost
+        then []
+        else begin
+          match need_recover_labeled_args expr.pexp_desc with
+          | Some e ->  [(Asttypes.Labelled str, e)]
+          | None ->  [(label, expr)]
+        end
+      | _ -> [(label, expr)]
+    ) args
+    in
+    let pexp_desc = Parsetree.Pexp_apply (expr, args) in
+    { base_expr with pexp_desc }
+  | _ -> base_expr
+
 let destruct_expression loc config source parents expr =
   let ty = expr.Typedtree.exp_type in
-  let pexp = filter_expr_attr (Untypeast.untype_expression expr) in
+  let pexp =
+    filter_expr_attr (Untypeast.untype_expression expr)
+    |> remove_non_applied_optional_args
+  in
   let () =
     log ~title:"node_expression" "%a"
       Logger.fmt (fun fmt -> Printast.expression 0 fmt pexp)

tests/test-dirs/destruct/issue1770.t

@@ -0,0 +1,162 @@
+  $ $MERLIN single case-analysis -start 2:10 -end 2:15 \
+  > -filename main.ml <<EOF
+  > let foo ?bar x = x
+  > let () = foo ()
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 9
+        },
+        "end": {
+          "line": 2,
+          "col": 15
+        }
+      },
+      "match foo () with | () -> _"
+    ],
+    "notifications": []
+  }
+
+$ $MERLIN single case-analysis -start 2:10 -end 2:15 \
+
+  $ $MERLIN single case-analysis -start 2:10 -end 2:15 \
+  > -filename main.ml <<EOF
+  > let foo ?bar x = x
+  > let () = foo ~bar:10 ()
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 9
+        },
+        "end": {
+          "line": 2,
+          "col": 23
+        }
+      },
+      "match foo ~bar:10 () with | () -> _"
+    ],
+    "notifications": []
+  }
+
+  $ $MERLIN single case-analysis -start 2:10 -end 2:15 \
+  > -filename main.ml <<EOF
+  > let foo ?bar x = x
+  > let () = foo ?bar:(Some 10) ()
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 9
+        },
+        "end": {
+          "line": 2,
+          "col": 30
+        }
+      },
+      "match foo ?bar:(Some 10) () with | () -> _"
+    ],
+    "notifications": []
+  }
+
+  $ $MERLIN single case-analysis -start 2:10 -end 2:15 \
+  > -filename main.ml <<EOF
+  > let foo ?(bar = 10) x = x
+  > let () = foo ()
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 9
+        },
+        "end": {
+          "line": 2,
+          "col": 15
+        }
+      },
+      "match foo () with | () -> _"
+    ],
+    "notifications": []
+  }
+
+  $ $MERLIN single case-analysis -start 2:10 -end 2:15 \
+  > -filename main.ml <<EOF
+  > let foo ?(bar = 10) x = x
+  > let () = foo ~bar:15 ()
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 9
+        },
+        "end": {
+          "line": 2,
+          "col": 23
+        }
+      },
+      "match foo ~bar:15 () with | () -> _"
+    ],
+    "notifications": []
+  }
+
+  $ $MERLIN single case-analysis -start 2:10 -end 2:15 \
+  > -filename main.ml <<EOF
+  > let foo ?(bar = 10) x = x
+  > let () = foo ?bar:None ()
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 9
+        },
+        "end": {
+          "line": 2,
+          "col": 25
+        }
+      },
+      "match foo ?bar:None () with | () -> _"
+    ],
+    "notifications": []
+  }
+
+  $ $MERLIN single case-analysis -start 2:10 -end 2:15 \
+  > -filename main.ml <<EOF
+  > let foo ?(bar = 10) x = x
+  > let () = foo ?bar:(Some 15) ()
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 9
+        },
+        "end": {
+          "line": 2,
+          "col": 30
+        }
+      },
+      "match foo ?bar:(Some 15) () with | () -> _"
+    ],
+    "notifications": []
+  }