Fix ocaml#1770

src/analysis/destruct.ml

@@ -588,9 +588,42 @@ module Conv = struct
     (ps, constrs, labels)
 end
 
+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 expr) =
+  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
+    { expr with pexp_desc }
+  | _ -> 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

@@ -16,7 +16,7 @@
           "col": 15
         }
       },
-      "match foo ?bar:None () with | () -> _"
+      "match foo () with | () -> _"
     ],
     "notifications": []
   }
@@ -41,7 +41,7 @@ $ $MERLIN single case-analysis -start 2:10 -end 2:15 \
           "col": 23
         }
       },
-      "match foo ?bar:(Some 10) () with | () -> _"
+      "match foo ~bar:10 () with | () -> _"
     ],
     "notifications": []
   }
@@ -87,7 +87,7 @@ $ $MERLIN single case-analysis -start 2:10 -end 2:15 \
           "col": 15
         }
       },
-      "match foo ?bar:None () with | () -> _"
+      "match foo () with | () -> _"
     ],
     "notifications": []
   }
@@ -110,7 +110,7 @@ $ $MERLIN single case-analysis -start 2:10 -end 2:15 \
           "col": 23
         }
       },
-      "match foo ?bar:(Some 15) () with | () -> _"
+      "match foo ~bar:15 () with | () -> _"
     ],
     "notifications": []
   }