Search by type feature, a kind of sherlodoc in Merlin

.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,10 +8,14 @@ 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)
   + editor modes
     - vim: fix python-3.12 syntax warnings in merlin.py (#1798)
     - vim: Dead code / doc removal for previously deleted MerlinPhrase command (#1804)
     - emacs: Improve the way that result of polarity search is displayed (#1814)
+    - emacs: Add `merlin-search-by-type`, `merlin-search-by-polarity` and change the
+	  behaviour of `merlin-search` to switch between `by-type` or `by-polarity`
+	  depending on the query (#1828)
 
 merlin 5.1
 ==========

doc/dev/PROTOCOL.md

@@ -425,6 +425,35 @@ The result is returned as a list of:
 
 Returns the type of the expression when typechecked in the environment around the specified position.
 
+### `search-by-polarity` -position <position> -query <string>
+
+	-position <position> Position to search
+	-query <string> The query
+
+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> -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.
+
+The result is returned as a list of:
+```javascript
+{
+  'file': filename, // the file where the definition is defined
+  'start': position,
+  'end': position,
+  'name': string, // the name of the definition
+  'type': string, // the type of the definition
+  'cost': int, // the cost/distance of the definition and the query
+  'doc': string | null // the docstring of the definition
+}
+```
+
 ### `check-configuration`
 
 

emacs/merlin.el

@@ -137,10 +137,6 @@ a call to `merlin-occurrences'."
 See `merlin-debug'."
   :group 'merlin :type 'string)
 
-(defcustom merlin-polarity-search-buffer-name "*merlin-polarity-search-result*"
-  "The name of the buffer displaying result of polarity search."
-  :group 'merlin :type 'string)
-
 (defcustom merlin-favourite-caml-mode nil
   "The OCaml mode to use for the *merlin-types* buffer."
   :group 'merlin :type 'symbol)
@@ -1094,51 +1090,70 @@ An ocaml atom is any string containing [a-z_0-9A-Z`.]."
     (cons (if bounds (car bounds) (point))
           (point))))
 
-;;;;;;;;;;;;;;;;;;;;;
-;; POLARITY SEARCH ;;
-;;;;;;;;;;;;;;;;;;;;;
 
-(defun merlin--search (query)
-  (merlin-call "search-by-polarity"
-               "-query" query
-               "-position" (merlin-unmake-point (point))))
+;;;;;;;;;;;;
+;; SEARCH ;;
+;;;;;;;;;;;;
 
-(defun merlin--get-polarity-buff ()
-  (get-buffer-create merlin-polarity-search-buffer-name))
+(defun merlin--search (query)
+  (merlin-call "search-by-type"
+	       "-query" query
+	       "-position" (merlin-unmake-point (point))))
 
-(defun merlin--render-polarity-result (name type)
+(defun merlin--search-format-key (name type doc)
   (let ((plain-name (string-remove-prefix "Stdlib__" name)))
     (concat
-     (propertize "val " 'face (intern "font-lock-keyword-face"))
      (propertize plain-name 'face (intern "font-lock-function-name-face"))
      " : "
-     (propertize type 'face (intern "font-lock-doc-face")))))
-
-(defun merlin--polarity-result-to-list (entry)
-  (let ((function-name (merlin-completion-entry-text "" entry))
-        (function-type (merlin-completion-entry-short-description entry)))
-    (list function-name
-          (vector (merlin--render-polarity-result function-name function-type)))))
+     (propertize type 'face (intern "font-lock-doc-face"))
+     " "
+     (propertize doc 'face (intern "font-lock-comment-face")))))
+
+(defun merlin--get-documentation-line-from-entry (entry)
+  (let* ((doc-entry (cdr (assoc 'doc entry)))
+         (doc (if (eq doc-entry 'null) "" doc-entry))
+	 (doc-lines (split-string doc "[\r\n]+")))
+    (car doc-lines)))
+
+(defun merlin--search-entry-to-completion-entry (entry)
+  (let ((value-name (cdr (assoc 'name entry)))
+	(value-hole (cdr (assoc 'constructible entry)))
+	(value-type (cdr (assoc 'type entry)))
+        (value-docs (merlin--get-documentation-line-from-entry entry)))
+    (let ((key (merlin--search-format-key value-name value-type value-docs))
+	  (value value-hole))
+      (cons key value))))
+
+(defun merlin--search-select-completion-result (choices selected)
+  (alist-get selected choices nil nil #'equal))
+
+(defun merlin--search-substitute-constructible (elt)
+  (progn
+    (when (region-active-p)
+      (delete-region (region-beginning) (region-end)))
+    (insert (concat "(" elt ")"))))
+
+(defun merlin--search-completion-presort (choices)
+  (lambda (string pred action)
+    (if (eq action 'metadata)
+	'(metadata (display-sort-function . identity)
+		   (cycle-sort-function . identity))
+      (complete-with-action action choices string pred))))
 
 (defun merlin-search (query)
-  (interactive "sSearch pattern: ")
-  (let* ((result (merlin--search query))
-         (entries (cdr (assoc 'entries result)))
-         (previous-buff (current-buffer)))
-    (let ((pol-buff (merlin--get-polarity-buff))
-          (inhibit-read-only t))
-      (with-current-buffer pol-buff
-        (switch-to-buffer-other-window pol-buff)
-        (goto-char 1)
-        (tabulated-list-mode)
-        (setq tabulated-list-format [("Polarity Search Result" 100 t)])
-        (setq tabulated-list-entries (mapcar 'merlin--polarity-result-to-list entries))
-        (setq tabulated-list-padding 2)
-        (face-spec-set 'header-line '((t :weight bold :height 1.2)))
-        (tabulated-list-init-header)
-        (tabulated-list-print t)
-        (setq buffer-read-only t)
-        (switch-to-buffer-other-window previous-buff)))))
+  "Search values by types or polarity"
+  (interactive "sSearch query: ")
+  (let* ((entries (merlin--search query))
+	 (choices
+	  (mapcar #'merlin--search-entry-to-completion-entry entries)))
+    (let ((constructible
+	   (merlin--search-select-completion-result
+	    choices
+	    (completing-read (concat "Candidates: ")
+			     (merlin--search-completion-presort choices)
+			     nil nil nil t))))
+      (merlin--search-substitute-constructible constructible))))
+
 
 ;;;;;;;;;;;;;;;;;
 ;; TYPE BUFFER ;;

merlin-lib.opam

@@ -13,6 +13,7 @@ depends: [
   "ocaml" {>= "5.2" & < "5.3"}
   "dune" {>= "3.0.0"}
   "csexp" {>= "1.5.1"}
+  "alcotest" {with-test}
   "menhir"    {dev & >= "20201216"}
   "menhirLib" {dev & >= "20201216"}
   "menhirSdk" {dev & >= "20201216"}

src/analysis/dune

@@ -19,6 +19,7 @@
   merlin_kernel
   merlin_utils
   merlin_index_format
+  merlin_sherlodoc
   ocaml_parsing
   ocaml_preprocess
   query_protocol

src/analysis/polarity_search.ml

@@ -83,6 +83,21 @@ let build_query ~positive ~negative env =
     pos_fun = !pos_fun
   }
 
+let prepare_query env query =
+  let re = Str.regexp "[ |\t]+" in
+  let pos, neg =
+    Str.split re query |> List.partition ~f:(fun s -> s.[0] <> '-')
+  in
+  let prepare s =
+    Longident.parse
+    @@
+    if s.[0] = '-' || s.[0] = '+' then
+      String.sub s ~pos:1 ~len:(String.length s - 1)
+    else s
+  in
+  build_query env ~positive:(List.map pos ~f:prepare)
+    ~negative:(List.map neg ~f:prepare)
+
 let directories ~global_modules env =
   let rec explore lident env =
     let add_module name _ md l =
@@ -129,3 +144,21 @@ let execute_query query env dirs =
       acc
   in
   List.fold_left dirs ~init:(direct None []) ~f:recurse
+
+(* [execute_query_as_type_search] runs a standard polarity_search query and map
+   the result for compatibility with the type-search interface. *)
+let execute_query_as_type_search ?(limit = 100) ~env ~query ~modules () =
+  execute_query query env modules
+  |> List.map ~f:(fun (cost, path, desc) ->
+         let name =
+           Printtyp.wrap_printing_env env @@ fun () ->
+           let path = Printtyp.rewrite_double_underscore_paths env path in
+           Format.asprintf "%a" Printtyp.path path
+         in
+         let doc = None in
+         let loc = desc.Types.val_loc in
+         let typ = desc.Types.val_type in
+         let constructible = Type_search.make_constructible name typ in
+         Query_protocol.{ cost; name; typ; loc; doc; constructible })
+  |> List.sort ~cmp:Type_search.compare_result
+  |> List.take_n limit

src/analysis/type_search.ml

@@ -0,0 +1,144 @@
+(* {{{ COPYING *(
+
+   This file is part of Merlin, an helper for ocaml editors
+
+   Copyright (C) 2013 - 2024  Frédéric Bour  <frederic.bour(_)lakaban.net>
+                              Thomas Refis  <refis.thomas(_)gmail.com>
+                              Simon Castellan  <simon.castellan(_)iuwt.fr>
+                              Arthur Wendling <arthur(_)tarides.com>
+                              Xavier Van de Woestyne <xaviervdw(_)gmail.com>
+
+   Permission is hereby granted, free of charge, to any person obtaining a
+   copy of this software and associated documentation files (the "Software"),
+   to deal in the Software without restriction, including without limitation the
+   rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+   sell copies of the Software, and to permit persons to whom the Software is
+   furnished to do so, subject to the following conditions:
+
+   The above copyright notice and this permission notice shall be included in
+   all copies or substantial portions of the Software.
+
+   The Software is provided "as is", without warranty of any kind, express or
+   implied, including but not limited to the warranties of merchantability,
+   fitness for a particular purpose and noninfringement. In no event shall
+   the authors or copyright holders be liable for any claim, damages or other
+   liability, whether in an action of contract, tort or otherwise, arising
+   from, out of or in connection with the software or the use or other dealings
+   in the Software.
+
+    )* }}} *)
+
+open Std
+
+let sherlodoc_type_of env typ =
+  let open Merlin_sherlodoc in
+  let rec aux typ =
+    match Types.get_desc typ with
+    | Types.Tvar None -> Type_parsed.Wildcard
+    | Types.Tvar (Some ty) -> Type_parsed.Tyvar ty
+    | Types.Ttuple elts -> Type_parsed.tuple @@ List.map ~f:aux elts
+    | Types.Tarrow (_, a, b, _) -> Type_parsed.Arrow (aux a, aux b)
+    | Types.Tconstr (p, args, _) ->
+      let p = Printtyp.rewrite_double_underscore_paths env p in
+      let name = Format.asprintf "%a" Printtyp.path p in
+      Type_parsed.Tycon (name, List.map ~f:aux args)
+    | _ -> Type_parsed.Unhandled
+  in
+  typ |> aux |> Type_expr.normalize_type_parameters
+
+let make_constructible path desc =
+  let holes =
+    match Types.get_desc desc with
+    | Types.Tarrow (l, _, b, _) ->
+      let rec aux acc t =
+        match Types.get_desc t with
+        | Types.Tarrow (l, _, b, _) -> aux (acc ^ with_label l) b
+        | _ -> acc
+      and with_label l =
+        match l with
+        | Ocaml_parsing.Asttypes.Nolabel -> " _"
+        | Labelled s -> " ~" ^ s ^ ":_"
+        | Optional _ -> ""
+      in
+      aux (with_label l) b
+    | _ -> ""
+  in
+  path ^ holes
+
+let doc_to_option = function
+  | `Builtin doc | `Found doc -> Some doc
+  | _ -> None
+
+let get_doc ~config ~env ~local_defs ~comments ~pos name =
+  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; _ } =
+  let c = Int.compare cost_a cost_b in
+  if Int.equal c 0 then
+    let c = Int.compare (String.length a) (String.length b) in
+    match (c, doc_a, doc_b) with
+    | 0, Some _, None -> 1
+    | 0, None, Some _ -> -1
+    | 0, Some doc_a, Some doc_b ->
+      let c = Int.compare (String.length doc_a) (String.length doc_b) in
+      (* Make default insertion determinist *)
+      if Int.equal 0 c then String.compare a b else c
+    | 0, None, None -> String.compare a b
+    | _ -> c
+  else c
+
+let compute_value 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
+  let name =
+    Printtyp.wrap_printing_env env @@ fun () ->
+    let path = Printtyp.rewrite_double_underscore_paths env path in
+    Format.asprintf "%a" Printtyp.path path
+  in
+  let cost = Query.distance_for query ~path:name typ in
+  if cost >= 1000 then acc
+  else
+    let doc = None in
+    let loc = desc.Types.val_loc in
+    let typ = desc.Types.val_type in
+    let constructible = make_constructible name d in
+    Query_protocol.{ cost; name; typ; loc; doc; constructible } :: acc
+
+let compute_values query env lident acc =
+  Env.fold_values (compute_value query env) lident env acc
+
+let values_from_module query env lident acc =
+  let rec aux acc lident =
+    match Env.find_module_by_name lident env with
+    | exception _ -> acc
+    | _ ->
+      let acc = compute_values query env (Some lident) acc in
+      Env.fold_modules
+        (fun name _ mdl acc ->
+          match mdl.Types.md_type with
+          | Types.Mty_alias _ -> acc
+          | _ ->
+            let lident = Longident.Ldot (lident, name) in
+            aux acc lident)
+        (Some lident) env acc
+  in
+  aux acc lident
+
+let run ?(limit = 100) ~env ~query ~modules () =
+  let init = compute_values query env None [] in
+  modules
+  |> List.fold_left ~init ~f:(fun acc name ->
+         let lident = Longident.Lident name in
+         values_from_module query env lident acc)
+  |> List.sort ~cmp:compare_result
+  |> List.take_n limit
+
+let classify_query query =
+  let query = String.trim query in
+  match query.[0] with
+  | '+' | '-' -> `Polarity query
+  | _ -> `By_type query
+  | exception Invalid_argument _ -> `Polarity query