Merge pull request #1866 from voodoos/414-4.18-backports

Backports for release 4.18-414

Author: voodoos

.github/workflows/changelog.yml

@@ -2,7 +2,7 @@ name: Changelog check
 
 on:
   pull_request:
-    branches: [ master ]
+    branches: [ main ]
     types: [ opened, synchronize, reopened, labeled, unlabeled ]
 
 jobs:

CHANGES.md

@@ -1,3 +1,15 @@
+merlin 4.18
+===========
+Tue Nov 26 17:30:42 CET 2024
+
+  + merlin binary
+    - Respect the `EXCLUDE_QUERY_DIR` configuration directive when looking for
+      cmt files (#1854)
+    - Fix exception in polarity search (#1858 fixes #1113)
+    - Fix type-enclosing results instability. This reverts some overly
+      aggressive deduplication that should be done on the client side. (#1864)
+
+
 merlin 4.17.1
 =============
 Fri Sep 27 12:02:42 CEST 2024

dot-merlin-reader.opam

@@ -12,7 +12,7 @@ build: [
 ]
 depends: [
   "ocaml" {>= "4.14"}
-  "dune" {>= "2.9.0"}
+  "dune" {>= "3.0.0"}
   "merlin-lib" {>= "4.17"}
   "ocamlfind" {>= "1.6.0"}
 ]

merlin-lib.opam

@@ -13,7 +13,7 @@ depends: [
   "ocaml" {>= "4.14" & < "4.15"}
   "dune" {>= "2.9.0"}
   "csexp" {>= "1.5.1"}
-  "alcotest" {with-test}
+  "alcotest" {with-test & >= "1.3.0" }
   "menhir"    {dev & >= "20201216"}
   "menhirLib" {dev & >= "20201216"}
   "menhirSdk" {dev & >= "20201216"}

merlin.opam

@@ -14,7 +14,7 @@ depends: [
   "ocaml" {>= "4.14" & < "4.15"}
   "dune" {>= "2.9.0"}
   "merlin-lib" {= version}
-  "dot-merlin-reader" {>= "4.17"}
+  "dot-merlin-reader" {>= "4.17.1"}
   "yojson" {>= "2.0.0"}
   "conf-jq" {with-test}
   "ppxlib" {with-test}

src/analysis/misc_utils.ml

@@ -59,3 +59,55 @@ let parse_identifier (config, source) pos =
     "paths: [%s]"
     (String.concat ~sep:";" (List.map path ~f:(fun l -> l.Location.txt)));
   path
+
+let reconstruct_identifier pipeline pos = function
+  | None ->
+    let config = Mpipeline.input_config pipeline in
+    let source = Mpipeline.raw_source pipeline in
+    let path = parse_identifier (config, source) pos in
+    let reify dot =
+      if
+        dot = ""
+        || (dot.[0] >= 'a' && dot.[0] <= 'z')
+        || (dot.[0] >= 'A' && dot.[0] <= 'Z')
+      then dot
+      else "( " ^ dot ^ ")"
+    in
+    begin
+      match path with
+      | [] -> []
+      | base :: tail ->
+        let f { Location.txt = base; loc = bl } { Location.txt = dot; loc = dl }
+            =
+          let loc = Location_aux.union bl dl in
+          let txt = base ^ "." ^ reify dot in
+          Location.mkloc txt loc
+        in
+        [ List.fold_left tail ~init:base ~f ]
+    end
+  | Some (expr, offset) ->
+    let loc_start =
+      let l, c = Lexing.split_pos pos in
+      Lexing.make_pos (l, c - offset)
+    in
+    let shift loc int =
+      let l, c = Lexing.split_pos loc in
+      Lexing.make_pos (l, c + int)
+    in
+    let add_loc source =
+      let loc =
+        { Location.loc_start;
+          loc_end = shift loc_start (String.length source);
+          loc_ghost = false
+        }
+      in
+      Location.mkloc source loc
+    in
+    let len = String.length expr in
+    let rec aux acc i =
+      if i >= len then List.rev_map ~f:add_loc (expr :: acc)
+      else if expr.[i] = '.' then
+        aux (String.sub expr ~pos:0 ~len:i :: acc) (succ i)
+      else aux acc (succ i)
+    in
+    aux [] offset

src/analysis/misc_utils.mli

@@ -29,3 +29,11 @@ val parenthesize_name : string -> string
     the location of each of its components. *)
 val parse_identifier :
   Mconfig.t * Msource.t -> Lexing.position -> string Location.loc list
+
+(** [reconstruct_identifier pipeline pos] returns growing ranges around [pos] and the
+  associated identifier. *)
+val reconstruct_identifier :
+  Mpipeline.t ->
+  Lexing.position ->
+  (string * int) option ->
+  string Location.loc list

src/analysis/polarity_search.ml

@@ -68,8 +68,10 @@ let build_query ~positive ~negative env =
       incr r;
       None)
     else
-      let set, _ = Env.find_type_by_name l env in
-      Some (normalize_path env set)
+      try
+        let set, _ = Env.find_type_by_name l env in
+        Some (normalize_path env set)
+      with Not_found -> None
   in
   let pos_fun = ref 0 and neg_fun = ref 0 in
   let positive = List.filter_map positive ~f:(prepare pos_fun) in

src/analysis/type_enclosing.ml

@@ -1,4 +1,5 @@
 open Std
+open Type_utils
 
 let log_section = "type-enclosing"
 let { Logger.log } = Logger.for_section log_section
@@ -7,11 +8,34 @@ type type_info =
   | Modtype of Env.t * Types.module_type
   | Type of Env.t * Types.type_expr
   | Type_decl of Env.t * Ident.t * Types.type_declaration
+  | Type_constr of Env.t * Types.constructor_description
   | String of string
 
 type typed_enclosings =
   (Location.t * type_info * Query_protocol.is_tail_position) list
 
+let print_type ~verbosity type_info =
+  let ppf = Format.str_formatter in
+  let wrap_printing_env = Printtyp.wrap_printing_env ~verbosity in
+  match type_info with
+  | Type (env, t) ->
+    wrap_printing_env env (fun () ->
+        print_type_with_decl ~verbosity env ppf t;
+        Format.flush_str_formatter ())
+  | Type_decl (env, id, t) ->
+    wrap_printing_env env (fun () ->
+        Printtyp.type_declaration env id ppf t;
+        Format.flush_str_formatter ())
+  | Type_constr (env, cd) ->
+    wrap_printing_env env (fun () ->
+        print_constr ~verbosity env ppf cd;
+        Format.flush_str_formatter ())
+  | Modtype (env, m) ->
+    wrap_printing_env env (fun () ->
+        Printtyp.modtype env ppf m;
+        Format.flush_str_formatter ())
+  | String s -> s
+
 let from_nodes ~path =
   let aux (env, node, tail) =
     let open Browse_raw in
@@ -89,14 +113,10 @@ let from_reconstructed ~nodes ~cursor ~verbosity exprs =
     (* Retrieve the type from the AST when it is possible *)
     | Some (Context.Constructor (cd, loc)) ->
       log ~title:"from_reconstructed" "ctx: constructor %s" cd.cstr_name;
-      let ppf, to_string = Format.to_string () in
-      Type_utils.print_constr ~verbosity env ppf cd;
-      Some (loc, String (to_string ()), `No)
+      Some (loc, Type_constr (env, cd), `No)
     | Some (Context.Label { lbl_name; lbl_arg; _ }) ->
       log ~title:"from_reconstructed" "ctx: label %s" lbl_name;
-      let ppf, to_string = Format.to_string () in
-      Type_utils.print_type_with_decl ~verbosity env ppf lbl_arg;
-      Some (loc, String (to_string ()), `No)
+      Some (loc, Type (env, lbl_arg), `No)
     | Some Context.Constant -> None
     | _ -> (
       let context = Option.value ~default:Context.Expr context in

src/analysis/type_enclosing.mli

@@ -38,11 +38,14 @@ type type_info =
   | Modtype of Env.t * Types.module_type
   | Type of Env.t * Types.type_expr
   | Type_decl of Env.t * Ident.t * Types.type_declaration
+  | Type_constr of Env.t * Types.constructor_description
   | String of string
 
 type typed_enclosings =
   (Location.t * type_info * Query_protocol.is_tail_position) list
 
+val print_type : verbosity:Mconfig.Verbosity.t -> type_info -> string
+
 val from_nodes :
   path:(Env.t * Browse_raw.node * Query_protocol.is_tail_position) list ->
   typed_enclosings