Include with-doc arg for search by type

.ocamlformat

@@ -8,4 +8,4 @@ dock-collection-brackets=false
 # Preserve begin/end
 exp-grouping=preserve
 module-item-spacing=preserve
-parse-docstrings=false
+parse-docstrings=false

CHANGES.md

@@ -8,7 +8,7 @@ unreleased
     - destruct: Refinement in the presence of optional arguments (#1800 #1807, fixes #1770)
     - Implement new expand-node command for expanding PPX annotations (#1745)
     - Implement new inlay-hints command for adding hints on a sourcetree (#1812)
-	- Implement new search-by-type command for searching values by types (#1828)
+    - Implement new search-by-type command for searching values by types (#1828)
   + editor modes
     - vim: fix python-3.12 syntax warnings in merlin.py (#1798)
     - vim: Dead code / doc removal for previously deleted MerlinPhrase command (#1804)

doc/dev/PROTOCOL.md

@@ -432,11 +432,12 @@ Returns the type of the expression when typechecked in the environment around th
 
 Returns a list (in the form of a completion list) of values matching the query. A query is defined by polarity (and does not support type parameters). Arguments are prefixed with `-` and the return type is prefixed with `+`. For example, to find a function that takes a string and returns an integer: `-string +int`. `-list +option` will returns every definition that take a list an option.
 
-### `search-by-type` -position <position> -query <string> -limit <int>
+### `search-by-type` -position <position> -query <string> -limit <int> -with-doc <bool>
 
 	-position <position> Position to search
 	-query <string> The query
 	-limit <int> a maximum-size of the result set
+	-with-doc <bool> if doc should be included in the result
 
 Returns a list of values matching the query. A query is a type expression, ie: `string -> int option` will search every definition that take a string and returns an option of int. It is also possible to search by polarity.
 

src/analysis/polarity_search.ml

@@ -143,32 +143,15 @@ let execute_query query env dirs =
   in
   List.fold_left dirs ~init:(direct None []) ~f:recurse
 
-let execute_query_as_type_search
-    ?(limit = 100)
-    ~config
-    ~local_defs
-    ~comments
-    ~pos
-    ~env
-    ~query
-    ~modules () =
+let execute_query_as_type_search ?(limit = 100) ~env ~query ~modules doc_ctx =
   let direct dir acc =
     Env.fold_values (fun _ path desc acc ->
         let d  = desc.Types.val_type in
         match match_query env query d with
         | Some cost ->
           let path = Printtyp.rewrite_double_underscore_paths env path in
           let name = Format.asprintf "%a" Printtyp.path path in
-          let doc =
-            Locate.get_doc
-              ~config
-              ~env
-              ~local_defs
-              ~comments
-              ~pos
-              (`User_input name)
-            |> Type_search.doc_to_option
-          in
+          let doc = Type_search.get_doc doc_ctx env name in
           let loc = desc.Types.val_loc in
           let typ =
             Format.asprintf "%a"

src/analysis/type_search.ml

@@ -70,6 +70,20 @@ let doc_to_option = function
   | `Found doc -> Some doc
   | _ -> None
 
+
+let get_doc doc_ctx env name =
+  match doc_ctx with
+  | None -> None
+  | Some (config, local_defs, comments, pos) ->
+    Locate.get_doc
+      ~config
+      ~env
+      ~local_defs
+      ~comments
+      ~pos
+      (`User_input name)
+    |> doc_to_option
+
 let compare_result
     Query_protocol.{cost = cost_a; name = a; doc = doc_a;  _}
     Query_protocol.{cost = cost_b; name = b; doc = doc_b;  _}
@@ -85,9 +99,7 @@ let compare_result
     | _ -> c
   else c
 
-let compute_value
-    (config, local_defs, comments, pos, query) env
-    _ path desc acc =
+let compute_value doc_ctx query env _ path desc acc =
   let open Merlin_sherlodoc in
   let d = desc.Types.val_type in
   let typ = sherlodoc_type_of env d in
@@ -96,16 +108,7 @@ let compute_value
   let cost = Query.distance_for query ~path:name typ in
   if cost >= 1000 then acc
   else
-    let doc =
-      Locate.get_doc
-        ~config
-        ~env
-        ~local_defs
-        ~comments
-        ~pos
-        (`User_input name)
-      |> doc_to_option
-    in
+    let doc = get_doc doc_ctx env name in
     let loc = desc.Types.val_loc in
     let typ =
       Format.asprintf "%a"
@@ -115,15 +118,15 @@ let compute_value
     let constructible = make_constructible name d in
     Query_protocol.{cost; name; typ; loc; doc; constructible} :: acc
 
-let compute_values ctx env lident acc =
-  Env.fold_values (compute_value ctx env) lident env acc
+let compute_values doc_ctx query env lident acc =
+  Env.fold_values (compute_value doc_ctx query env) lident env acc
 
-let values_from_module ctx env lident acc =
+let values_from_module doc_ctx query env lident acc =
   let rec aux acc lident =
     match Env.find_module_by_name lident env with
     | exception _ -> acc
     | _ -> 
-      let acc = compute_values ctx env (Some lident) acc in
+      let acc = compute_values doc_ctx query env (Some lident) acc in
       Env.fold_modules (fun name _ mdl acc ->
           match mdl.Types.md_type with
           | Types.Mty_alias _ -> acc
@@ -135,23 +138,14 @@ let values_from_module ctx env lident acc =
   aux acc lident
 
 
-let run
-    ?(limit = 100)
-    ~config
-    ~local_defs
-    ~comments
-    ~pos
-    ~env
-    ~query
-    ~modules () =
-  let ctx = (config, local_defs, comments, pos, query) in
-  let init = compute_values ctx env None [] in
+let run ?(limit = 100) ~env ~query ~modules doc_ctx =
+  let init = compute_values doc_ctx query env None [] in
   modules
   |> List.fold_left
     ~init
     ~f:(fun acc name ->
         let lident = Longident.Lident name in
-        values_from_module ctx env lident acc
+        values_from_module doc_ctx query env lident acc
       )
   |> List.sort ~cmp:compare_result
   |> List.take_n limit

src/analysis/type_search.mli

@@ -33,17 +33,22 @@
 (** Compute the list of candidates from a query inside a given environment. *)
 val run :
   ?limit:int ->
-  config:Mconfig.t ->
-  local_defs:Mtyper.typedtree ->
-  comments:(string * Location.t) list ->
-  pos:Lexing.position ->
   env:Env.t ->
   query:Merlin_sherlodoc.Query.t
   -> modules:string list
-  -> unit
+  -> (Mconfig.t
+      * Mtyper.typedtree
+      * (string * Location.t) list
+      * Lexing.position)
+    option
   -> Query_protocol.type_search_result list
 
-val doc_to_option : [> `Builtin of string | `Found of string ] -> string option
+val get_doc :
+  (Mconfig.t
+   *  Mtyper.typedtree
+   * (string * Warnings.loc) list
+   * Lexing.position) option -> Env.t -> string -> string option
+
 val make_constructible : string -> Types.type_expr -> string
 val compare_result :
    Query_protocol.type_search_result ->

src/commands/query_json.ml

@@ -178,11 +178,12 @@ let dump (type a) : a t -> json =
   | Polarity_search (query, pos) ->
     mk "polarity-search"
       [ ("query", `String query); ("position", mk_position pos) ]
-  | Type_search (query, pos, limit) ->
+  | Type_search (query, pos, limit, with_doc) ->
     mk "type-search"
       [ ("query", `String query);
         ("position", mk_position pos);
-        ("limit", `Int limit)
+        ("limit", `Int limit);
+        ("with-doc", `Bool with_doc)
       ]
   | Occurrences (`Ident_at pos, scope) ->
     mk "occurrences"

src/frontend/query_commands.ml

@@ -462,26 +462,30 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function
              { Compl.name; kind = `Value; desc; info = ""; deprecated = false })
     in
     { Compl.entries; context = `Unknown }
-  | Type_search (query, pos, limit) ->
+  | Type_search (query, pos, limit, with_doc) ->
     let typer = Mpipeline.typer_result pipeline in
-    let local_defs = Mtyper.get_typedtree typer in
     let pos = Mpipeline.get_lexing_pos pipeline pos in
     let node = Mtyper.node_at typer pos in
     let env, _ = Mbrowse.leaf_node node in
     let config = Mpipeline.final_config pipeline in
-    let comments = Mpipeline.reader_comments pipeline in
     let modules = Mconfig.global_modules config in
+    let doc_ctx =
+      if with_doc then
+        let comments = Mpipeline.reader_comments pipeline in
+        let local_defs = Mtyper.get_typedtree typer in
+        Some (config, local_defs, comments, pos)
+      else None
+    in
     begin
       match Type_search.classify_query query with
       | `By_type query ->
         let query = Merlin_sherlodoc.Query.from_string query in
-        Type_search.run ~limit ~config ~local_defs ~comments ~pos ~env ~query
-          ~modules ()
+        Type_search.run ~limit ~env ~query ~modules doc_ctx
       | `Polarity query ->
         let query = Polarity_search.prepare_query env query in
         let modules = Polarity_search.directories ~global_modules:modules env in
-        Polarity_search.execute_query_as_type_search ~limit ~config ~local_defs
-          ~comments ~pos ~env ~query ~modules ()
+        Polarity_search.execute_query_as_type_search ~limit ~env ~query ~modules
+          doc_ctx
     end
   | Refactor_open (mode, pos) ->
     let typer = Mpipeline.typer_result pipeline in

src/frontend/query_protocol.ml

@@ -148,7 +148,9 @@ type _ t =
       string * Msource.position * Compl.kind list * [ `with_types ] _bool
       -> completions t
   | Polarity_search : string * Msource.position -> completions t
-  | Type_search : string * Msource.position * int -> type_search_result list t
+  | Type_search :
+      string * Msource.position * int * bool
+      -> type_search_result list t
   | Refactor_open :
       [ `Qualify | `Unqualify ] * Msource.position
       -> (string * Location.t) list t

tests/test-dirs/search-by-type-comparison-to-polarity-search.t

@@ -132,17 +132,17 @@ map).
     "name": "Seq.map",
     "type": "('a -> 'b) -> 'a Stdlib__Seq.t -> 'b Stdlib__Seq.t"
   }
-  {
-    "name": "List.concat_map",
-    "type": "('a -> 'b list) -> 'a list -> 'b list"
-  }
   {
     "name": "List.filter_map",
     "type": "('a -> 'b option) -> 'a list -> 'b list"
   }
   {
-    "name": "ListLabels.concat_map",
-    "type": "f:('a -> 'b list) -> 'a list -> 'b list"
+    "name": "List.concat_map",
+    "type": "('a -> 'b list) -> 'a list -> 'b list"
+  }
+  {
+    "name": "ListLabels.filter_map",
+    "type": "f:('a -> 'b option) -> 'a list -> 'b list"
   }