Allows a search by type to be searched by polarity

src/analysis/polarity_search.ml

@@ -94,6 +94,19 @@ let build_query ~positive ~negative env =
     neg_fun = !neg_fun; 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 =
@@ -138,3 +151,44 @@ let execute_query query env dirs =
       acc
   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 dirs =
+  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 path = Format.asprintf "%a" Printtyp.path path in
+          let doc =
+            Locate.get_doc
+              ~config
+              ~env
+              ~local_defs
+              ~comments
+              ~pos
+              (`User_input path)
+            |> Type_search.doc_to_option
+          in
+          let constructible = Type_search.make_constructible path d in
+          (cost, path, desc, doc, constructible) :: acc
+        | None -> acc
+      ) dir env acc
+  in
+  let rec recurse acc (Trie (_, dir, children)) =
+    match
+      ignore (Env.find_module_by_name dir env);
+      Lazy.force children
+    with
+    | children ->
+      List.fold_left ~f:recurse ~init:(direct (Some dir) acc) children
+    | exception Not_found ->
+      Logger.notify ~section:"polarity-search" "%S not found"
+        (String.concat ~sep:"." (Longident.flatten dir));
+      acc
+  in
+  dirs
+  |> List.fold_left ~init:(direct None []) ~f:recurse
+  |> List.sort ~cmp:Type_search.compare_result
+  |> List.take_n limit

src/analysis/type_search.ml

@@ -93,6 +93,18 @@ let doc_to_option = function
   | `Found doc -> Some doc
   | _ -> None
 
+let compare_result (cost_a, a, _, doc_a, _) (cost_b, b, _, 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 a, Some b ->
+      Int.compare (String.length a) (String.length b)
+    | _ -> c
+  else c
+
 let run ?(limit = 100) config local_defs comments pos env query trie =
   let fold_values dir acc =
     Env.fold_values (fun _ path desc acc ->
@@ -132,18 +144,12 @@ let run ?(limit = 100) config local_defs comments pos env query trie =
   let init = fold_values None [] in
   trie
   |> List.fold_left ~init ~f:walk
-  |> List.sort ~cmp:(fun (cost_a, a, _, doc_a, _) (cost_b, b, _, 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 a, Some b ->
-          Int.compare (String.length a) (String.length b)
-        | _ -> c
-      else c
-    )
+  |> 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 _ -> `Polarity query

src/analysis/type_search.mli

@@ -47,3 +47,12 @@ val run :
   Merlin_sherlodoc.Query_parser.t
   -> t
   -> (int * string * Types.value_description * string option * string) list
+
+val doc_to_option : [> `Builtin of string | `Found of string ] -> string option
+val make_constructible : string -> Types.type_expr -> string
+val compare_result :
+  int * string * Types.value_description * string option * string ->
+  int * string * Types.value_description * string option * string ->
+  int
+
+val classify_query : string -> [ `By_type of string | `Polarity of string ]

src/frontend/query_commands.ml

@@ -446,19 +446,7 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a =
     let typer = Mpipeline.typer_result pipeline in
     let pos = Mpipeline.get_lexing_pos pipeline pos in
     let env, _ = Mbrowse.leaf_node (Mtyper.node_at typer pos) in
-    let 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
-      Polarity_search.build_query env
-        ~positive:(List.map pos ~f:prepare)
-        ~negative:(List.map neg ~f:prepare)
-    in
+    let query = Polarity_search.prepare_query env query in
     let config = Mpipeline.final_config pipeline in
     let global_modules = Mconfig.global_modules config in
     let dirs = Polarity_search.directories ~global_modules env in
@@ -478,7 +466,6 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a =
     { Compl. entries ; context = `Unknown }
 
   | Type_search (query, pos, limit) ->
-    let query = Merlin_sherlodoc.Query_parser.from_string query in
     let typer = Mpipeline.typer_result pipeline in
     let local_defs = Mtyper.get_typedtree typer in
     let pos = Mpipeline.get_lexing_pos pipeline pos in
@@ -487,10 +474,18 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a =
     let config = Mpipeline.final_config pipeline in
     let comments = Mpipeline.reader_comments pipeline in
     let modules = Mconfig.global_modules config in
-    let trie = Type_search.make_trie env modules in
-    let result =
-      Type_search.run
-        ~limit config local_defs comments pos env query trie
+    let result = match Type_search.classify_query query with
+      | `By_type query ->
+        let query = Merlin_sherlodoc.Query_parser.from_string query in
+        let trie = Type_search.make_trie env modules in
+        Type_search.run
+          ~limit config local_defs comments pos env query trie
+      | `Polarity query ->
+        let query = Polarity_search.prepare_query env query in
+        let dirs = Polarity_search.directories ~global_modules:modules env in
+        Polarity_search.execute_query_as_type_search
+           ~limit config local_defs comments pos env query dirs
+
     in
     let verbosity = verbosity pipeline in
     Printtyp.wrap_printing_env ~verbosity env (fun () ->
@@ -503,7 +498,7 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a =
           in
           { name; typ; cost; loc; doc; constructible}
         ) result
-    )
+      )
 
   | Refactor_open (mode, pos) ->
     let typer = Mpipeline.typer_result pipeline in

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

@@ -144,3 +144,99 @@ map).
     "name": "ListLabels.concat_map",
     "type": "f:('a -> 'b list) -> 'a list -> 'b list"
   }
+
+
+4.) Looking for a function that take a list of list of flatten-it into
+a list.
+
+
+  $ $MERLIN single search-by-type -filename ./main.ml \
+  > -position 5:25 -limit 10 -query "'a list list -> 'a list" |
+  > tr '\n' ' ' | jq  '.value[] | {name,type}'
+  {
+    "name": "List.concat",
+    "type": "'a list list -> 'a list"
+  }
+  {
+    "name": "List.flatten",
+    "type": "'a list list -> 'a list"
+  }
+  {
+    "name": "ListLabels.concat",
+    "type": "'a list list -> 'a list"
+  }
+  {
+    "name": "ListLabels.flatten",
+    "type": "'a list list -> 'a list"
+  }
+  {
+    "name": "Array.concat",
+    "type": "'a array list -> 'a array"
+  }
+  {
+    "name": "ArrayLabels.concat",
+    "type": "'a array list -> 'a array"
+  }
+  {
+    "name": "Seq.concat",
+    "type": "'a Stdlib__Seq.t Stdlib__Seq.t -> 'a Stdlib__Seq.t"
+  }
+  {
+    "name": "Option.join",
+    "type": "'a option option -> 'a option"
+  }
+  {
+    "name": "Seq.transpose",
+    "type": "'a Stdlib__Seq.t Stdlib__Seq.t -> 'a Stdlib__Seq.t Stdlib__Seq.t"
+  }
+  {
+    "name": "Result.join",
+    "type": "(('a, 'e) result, 'e) result -> ('a, 'e) result"
+  }
+
+5.) Using polarity query inside search by type (result are a bit
+different because type path are a little bit different)
+
+  $ $MERLIN single search-by-type -filename ./main.ml \
+  > -position 5:25 -limit 10 -query "-list -list +list" |
+  > tr '\n' ' ' | jq  '.value[] | {name,type}'
+  {
+    "name": "List.tl",
+    "type": "'a list -> 'a list"
+  }
+  {
+    "name": "List.rev",
+    "type": "'a list -> 'a list"
+  }
+  {
+    "name": "ListLabels.tl",
+    "type": "'a list -> 'a list"
+  }
+  {
+    "name": "ListLabels.rev",
+    "type": "'a list -> 'a list"
+  }
+  {
+    "name": "List.concat",
+    "type": "'a list list -> 'a list"
+  }
+  {
+    "name": "List.flatten",
+    "type": "'a list list -> 'a list"
+  }
+  {
+    "name": "ListLabels.concat",
+    "type": "'a list list -> 'a list"
+  }
+  {
+    "name": "ListLabels.flatten",
+    "type": "'a list list -> 'a list"
+  }
+  {
+    "name": "List.cons",
+    "type": "'a -> 'a list -> 'a list"
+  }
+  {
+    "name": "ListLabels.cons",
+    "type": "'a -> 'a list -> 'a list"
+  }