Refactor and fix deduplication in type enclosing.

Deduplication can only be done if the type have been printed. We perform that printing only at the junction between the reconstructed identifier enclosings and the ones from the tree nodes because we often want to keep both. All other duplicated ranges are removed.

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

@@ -31,3 +31,11 @@ val parenthesize_name : string -> string
     the location of each of its components. *)
 val parse_identifier :
   Mconfig.t * Msource.t -> Lexing.position -> modname 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/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

src/frontend/query_commands.ml

@@ -199,58 +199,6 @@ let dump pipeline = function
        source, parsetree, ppxed-source, ppxed-parsetree, typedtree, \
        env/fullenv (at {col:, line:})"
 
-let reconstruct_identifier pipeline pos = function
-  | None ->
-    let config = Mpipeline.input_config pipeline in
-    let source = Mpipeline.raw_source pipeline in
-    let path = Misc_utils.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
-
 let dispatch pipeline (type a) : a Query_protocol.t -> a = function
   | Type_expr (source, pos) ->
     let typer = Mpipeline.typer_result pipeline in
@@ -275,10 +223,14 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function
       | browse -> Browse_misc.annotate_tail_calls browse
     in
 
-    let result = Type_enclosing.from_nodes ~path in
+    let enclosing_nodes =
+      let cmp (loc1, _, _) (loc2, _, _) = Location_aux.compare loc1 loc2 in
+      (* There might be duplicates in the list *)
+      Type_enclosing.from_nodes ~path |> List.dedup_adjacent ~cmp
+    in
 
     (* enclosings of cursor in given expression *)
-    let exprs = reconstruct_identifier pipeline pos expro in
+    let exprs = Misc_utils.reconstruct_identifier pipeline pos expro in
     let () =
       Logger.log ~section:Type_enclosing.log_section
         ~title:"reconstruct identifier" "%a" Logger.json (fun () ->
@@ -303,41 +255,43 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function
              (fun fmt (loc, _, _) -> Location.print_loc fmt loc))
           small_enclosings);
 
-    let ppf = Format.str_formatter in
     let all_results =
-      List.mapi (small_enclosings @ result) ~f:(fun i (loc, text, tail) ->
-          let print =
-            match index with
-            | None -> true
-            | Some index -> index = i
-          in
-          let ret x = (loc, x, tail) in
-          match text with
-          | Type_enclosing.String str -> ret (`String str)
-          | Type_enclosing.Type (env, t) when print ->
-            Printtyp.wrap_printing_env env ~verbosity (fun () ->
-                Type_utils.print_type_with_decl ~verbosity env ppf t);
-            ret (`String (Format.flush_str_formatter ()))
-          | Type_enclosing.Type_decl (env, id, t) when print ->
-            Printtyp.wrap_printing_env env ~verbosity (fun () ->
-                Printtyp.type_declaration env id ppf t);
-            ret (`String (Format.flush_str_formatter ()))
-          | Type_enclosing.Modtype (env, m) when print ->
-            Printtyp.wrap_printing_env env ~verbosity (fun () ->
-                Printtyp.modtype env ppf m);
-            ret (`String (Format.flush_str_formatter ()))
-          | _ -> ret (`Index i))
-    in
-    let normalize ({ Location.loc_start; loc_end; _ }, text, _tail) =
-      (Lexing.split_pos loc_start, Lexing.split_pos loc_end, text)
-    in
-    (* We remove duplicates from the list. Duplicates can appear when the type
-       from the reconstructed identifier is the same as the one stored in the
-       typedtree *)
-    List.merge_cons
-      ~f:(fun a b ->
-        if compare (normalize a) (normalize b) = 0 then Some b else None)
-      all_results
+      let same_loc (l1, _, _) (l2, _, _) = Location_aux.compare l1 l2 == 0 in
+      let print_type (loc, type_info, tail) =
+        let open Type_enclosing in
+        (loc, String (print_type ~verbosity type_info), tail)
+      in
+      let rec concat_dedup acc l1 l2 =
+        match (l1, l2) with
+        | [ last ], first :: rest ->
+          (* The last reconstructed enclosing might be a duplicate of the first
+             enclosing from the tree. We need to print these enclosings types to
+             check if they differ or not. *)
+          if same_loc last first then
+            let ((_, last_type, _) as last) = print_type last in
+            let ((_, first_type, _) as first) = print_type first in
+            if last_type = first_type then concat_dedup (first :: acc) [] rest
+            else concat_dedup (last :: acc) [] (first :: rest)
+          else concat_dedup (last :: acc) [] l2
+        | hd :: tl, _ -> concat_dedup (hd :: acc) tl l2
+        | [], _ -> List.rev_append acc l2
+      in
+      concat_dedup [] small_enclosings enclosing_nodes
+    in
+    List.mapi all_results ~f:(fun i (loc, text, tail) ->
+        let print =
+          match index with
+          | None -> true
+          | Some index -> index = i
+        in
+        let ret x = (loc, x, tail) in
+        match text with
+        | Type_enclosing.String str -> ret (`String str)
+        | type_info ->
+          if print then
+            let printed_type = Type_enclosing.print_type ~verbosity type_info in
+            ret (`String printed_type)
+          else ret (`Index i))
   | Enclosing pos ->
     let typer = Mpipeline.typer_result pipeline in
     let structures = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in
@@ -509,7 +463,7 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function
       match patho with
       | Some p -> p
       | None ->
-        let path = reconstruct_identifier pipeline pos None in
+        let path = Misc_utils.reconstruct_identifier pipeline pos None in
         let path = Mreader_lexer.identifier_suffix path in
         let path = List.map ~f:(fun { Location.txt; _ } -> txt) path in
         String.concat ~sep:"." path
@@ -545,7 +499,7 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function
       match patho with
       | Some p -> p
       | None ->
-        let path = reconstruct_identifier pipeline pos None in
+        let path = Misc_utils.reconstruct_identifier pipeline pos None in
         let path = Mreader_lexer.identifier_suffix path in
         let path = List.map ~f:(fun { Location.txt; _ } -> txt) path in
         let path = String.concat ~sep:"." path in
@@ -822,7 +776,7 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function
     let pos = Mpipeline.get_lexing_pos pipeline pos in
     let env, _node = Mbrowse.leaf_node (Mtyper.node_at typer_result pos) in
     let path =
-      let path = reconstruct_identifier pipeline pos None in
+      let path = Misc_utils.reconstruct_identifier pipeline pos None in
       let path = Mreader_lexer.identifier_suffix path in
       let path = List.map ~f:(fun { Location.txt; _ } -> txt) path in
       let path = String.concat ~sep:"." path in

tests/test-dirs/type-enclosing/generic-types.t

@@ -26,7 +26,7 @@ With index 0 only the first type is shown:
       "line": 1,
       "col": 16
     },
-    "type": 1,
+    "type": "(int -> int) -> int list -> int list",
     "tail": "no"
   }
 
@@ -176,18 +176,6 @@ next type was not rendered.
         "type": "(int -> int) -> int list -> int list",
         "tail": "no"
       },
-      {
-        "start": {
-          "line": 2,
-          "col": 8
-        },
-        "end": {
-          "line": 2,
-          "col": 16
-        },
-        "type": 1,
-        "tail": "no"
-      },
       {
         "start": {
           "line": 2,
@@ -197,7 +185,7 @@ next type was not rendered.
           "line": 2,
           "col": 27
         },
-        "type": 2,
+        "type": 1,
         "tail": "no"
       }
     ],
@@ -232,7 +220,7 @@ should have been shorter earlier.
           "line": 2,
           "col": 27
         },
-        "type": 2,
+        "type": "int list",
         "tail": "no"
       }
     ],