Only omit prefix conditionally

CHANGES.md

@@ -3,7 +3,8 @@ unreleased
   + merlin binary
     - Handle concurrent server start (#1622)
     - Omit module prefixes for constructors and record fields in the
-      `construct` command (#1618).
+      `construct` command (#1618).  Prefixes are still produced when
+      warning 42 (disambiguated name) is active.
   + editor modes
     - emacs: call merlin-client-logger with "interrupted" if the
       merlin binary itself is interrupted, not just the parsing of the

src/analysis/construct.ml

@@ -62,8 +62,10 @@ module Util = struct
     in
     tbl
 
-  let prefix env ~env_check path name =
-    to_shortest_lid ~env ~env_check ~name path
+  let prefix env ~env_check ~omit_if_possible path name =
+    match omit_if_possible, Warnings.is_active (Disambiguated_name "") with
+    | true, false -> Longident.Lident name
+    | _ -> to_shortest_lid ~env ~env_check ~name path
 
   let var_of_id id = Location.mknoloc @@ Ident.name id
 
@@ -189,7 +191,7 @@ module Gen = struct
   let make_value env (path, (name, _value_description, params)) =
     let open Ast_helper in
     let env_check = Env.find_value_by_name in
-    let lid = Location.mknoloc (Util.prefix env ~env_check path name) in
+    let lid = Location.mknoloc (Util.prefix env ~env_check ~omit_if_possible:false path name) in
     let params = List.map params
       ~f:(fun label -> label, Exp.hole ())
     in
@@ -331,17 +333,23 @@ module Gen = struct
           | _ -> Ast_helper.Pat.any (), "_" end
     in
 
-    let constructor env type_expr constrs =
+    let constructor env type_expr path constrs =
       log ~title:"constructors" "[%s]"
         (String.concat ~sep:"; "
           (List.map constrs ~f:(fun c -> c.Types.cstr_name)));
       (* [make_constr] builds the PAST repr of a type constructor applied
       to holes *)
-      let make_constr env type_expr cstr_descr =
+      let make_constr env path type_expr cstr_descr =
         let ty_args, ty_res, _ = Ctype.instance_constructor cstr_descr in
         match Util.unifiable env type_expr ty_res with
         | Some snap ->
-          let lid = Location.mknoloc (Longident.Lident cstr_descr.cstr_name) in
+          let lid =
+            Util.prefix env
+              ~env_check:Env.find_constructor_by_name
+              ~omit_if_possible:true
+              path cstr_descr.cstr_name
+            |> Location.mknoloc
+          in
           let args = List.map ty_args ~f:(exp_or_hole env) in
           let args_combinations = Util.combinations args in
           let exps = List.map args_combinations
@@ -364,7 +372,7 @@ module Gen = struct
               else None)
         | None -> []
       in
-      List.map constrs ~f:(make_constr env type_expr)
+      List.map constrs ~f:(make_constr env path type_expr)
       (* [constrs] are ordered inversly to a source code declaration.
          We reverse it to match it and provide better UX *)
       |> List.rev
@@ -399,15 +407,21 @@ module Gen = struct
         |> List.rev
     in
 
-    let record env typ labels =
+    let record env typ path labels =
       log ~title:"record labels" "[%s]"
         (String.concat ~sep:"; "
           (List.map labels ~f:(fun l -> l.Types.lbl_name)));
 
       let labels = List.map labels ~f:(fun ({ lbl_name; _ } as lbl) ->
         let _, arg, res = Ctype.instance_label true lbl in
         Ctype.unify env res typ ;
-        let lid = Location.mknoloc (Longident.Lident lbl_name) in
+        let lid =
+          Util.prefix env
+            ~env_check:Env.find_label_by_name
+            ~omit_if_possible:true
+            path lbl_name
+          |> Location.mknoloc
+        in
         let exprs = exp_or_hole env arg in
         lid, exprs)
       in
@@ -450,8 +464,8 @@ module Gen = struct
           with Not_found ->
             let def = Env.find_type_descrs path env in
             match def with
-            | Type_variant (constrs, _) -> constructor env rtyp constrs
-            | Type_record (labels, _) -> record env rtyp labels
+            | Type_variant (constrs, _) -> constructor env rtyp path constrs
+            | Type_record (labels, _) -> record env rtyp path labels
             | Type_abstract | Type_open -> []
           end
         | Tarrow (label, tyleft, tyright, _) ->
@@ -538,21 +552,23 @@ let to_string_with_parentheses exp =
   in
   Format.asprintf f Pprintast.expression exp
 
-let node ?(depth = 1) ~keywords ~values_scope node =
-  match node with
-  | Browse_raw.Expression { exp_type; exp_env; _ } ->
-      let idents_table = Util.idents_table ~keywords in
-      Gen.expression ~idents_table values_scope ~depth exp_env exp_type
-      |> List.map ~f:to_string_with_parentheses
-  | Browse_raw.Module_expr
-      { mod_desc = Tmod_constraint _ ; mod_type; mod_env; _ }
-  | Browse_raw.Module_expr
-      {  mod_desc = Tmod_apply _; mod_type; mod_env; _ } ->
-      let m = Gen.module_ mod_env mod_type in
-      [ Format.asprintf "%a" Pprintast.module_expr m ]
-  | Browse_raw.Module_expr _
-  | Browse_raw.Module_binding _ ->
-      (* Constructible modules have an explicit constraint or are functor
-        applications. In other cases we do not know what to construct.  *)
-      raise No_constraint
-  | _ -> raise Not_a_hole
+let node ?(depth = 1) ~(config : Mconfig.t) ~keywords ~values_scope node =
+  Warnings.with_state config.ocaml.warnings
+    (fun () ->
+       match node with
+       | Browse_raw.Expression { exp_type; exp_env; _ } ->
+         let idents_table = Util.idents_table ~keywords in
+         Gen.expression ~idents_table values_scope ~depth exp_env exp_type
+         |> List.map ~f:to_string_with_parentheses
+       | Browse_raw.Module_expr
+           { mod_desc = Tmod_constraint _ ; mod_type; mod_env; _ }
+       | Browse_raw.Module_expr
+           {  mod_desc = Tmod_apply _; mod_type; mod_env; _ } ->
+         let m = Gen.module_ mod_env mod_type in
+         [ Format.asprintf "%a" Pprintast.module_expr m ]
+       | Browse_raw.Module_expr _
+       | Browse_raw.Module_binding _ ->
+         (* Constructible modules have an explicit constraint or are functor
+            applications. In other cases we do not know what to construct.  *)
+         raise No_constraint
+       | _ -> raise Not_a_hole)

src/analysis/construct.mli

@@ -5,6 +5,7 @@ type values_scope = Null | Local
 
 val node
   : ?depth : int
+  -> config : Mconfig.t
   -> keywords : string list
   -> values_scope : values_scope
   -> Browse_raw.node

src/frontend/query_commands.ml

@@ -623,6 +623,7 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a =
       | Some `None | None -> Construct.Null
       | Some `Local -> Construct.Local
     in
+    let config = Mpipeline.final_config pipeline in
     let keywords = Mpipeline.reader_lexer_keywords pipeline in
     let typer = Mpipeline.typer_result pipeline in
     let typedtree = Mtyper.get_typedtree typer in
@@ -633,11 +634,11 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a =
     | (_, (Browse_raw.Module_expr { mod_desc = Tmod_hole; _ } as node_for_loc))
       :: (_, node) :: _parents ->
         let loc = Mbrowse.node_loc node_for_loc in
-        (loc, Construct.node ~keywords ?depth ~values_scope node)
+        (loc, Construct.node ~config ~keywords ?depth ~values_scope node)
     | (_,  (Browse_raw.Expression { exp_desc = Texp_hole; _ } as node))
       :: _parents ->
       let loc = Mbrowse.node_loc node in
-      (loc, Construct.node ~keywords ?depth ~values_scope node)
+      (loc, Construct.node ~config ~keywords ?depth ~values_scope node)
     | _ :: _ -> raise Construct.Not_a_hole
     | [] -> raise No_nodes
     end

tests/test-dirs/construct/c-prefix.t

@@ -99,3 +99,30 @@ Test 1.3 :
     "{ a = _ }"
   ]
 
+With warning 42 (disambiguated name) active, prefixes are added:
+
+  $ $MERLIN single construct -position 5:20 -filename c13.ml <c13.ml -w +disambiguated-name |
+  >  jq ".value[1]"
+  [
+    "(Prefix.A _)",
+    "Prefix.B"
+  ]
+
+  $ $MERLIN single construct -position 6:20 -filename c13.ml <c13.ml -w +disambiguated-name |
+  >  jq ".value[1]"
+  [
+    "{ Prefix.a = _ }"
+  ]
+
+  $ $MERLIN single construct -position 8:13 -filename c13.ml <c13.ml -w +disambiguated-name |
+  >  jq ".value[1]"
+  [
+    "(A _)",
+    "B"
+  ]
+
+  $ $MERLIN single construct -position 9:13 -filename c13.ml <c13.ml -w +disambiguated-name |
+  >  jq ".value[1]"
+  [
+    "{ a = _ }"
+  ]