Some refactoring according to @voodoos feedback

src/analysis/polarity_search.ml

@@ -153,26 +153,39 @@ let execute_query query env dirs =
   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 =
+    ?(limit = 100)
+    ~config
+    ~local_defs
+    ~comments
+    ~pos
+    ~env
+    ~query
+    ~modules () =
   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 name = Format.asprintf "%a" Printtyp.path path in
           let doc =
             Locate.get_doc
               ~config
               ~env
               ~local_defs
               ~comments
               ~pos
-              (`User_input path)
+              (`User_input name)
             |> Type_search.doc_to_option
           in
-          let constructible = Type_search.make_constructible path d in
-          (cost, path, desc, doc, constructible) :: acc
+          let loc = desc.Types.val_loc in
+          let typ =
+            Format.asprintf "%a"
+              (Type_utils.Printtyp.type_scheme env)
+              desc.Types.val_type
+          in
+          let constructible = Type_search.make_constructible name d in
+          Query_protocol.{cost; name; typ; loc; doc; constructible} :: acc
         | None -> acc
       ) dir env acc
   in
@@ -188,7 +201,7 @@ let execute_query_as_type_search
         (String.concat ~sep:"." (Longident.flatten dir));
       acc
   in
-  dirs
+  modules
   |> List.fold_left ~init:(direct None []) ~f:recurse
   |> List.sort ~cmp:Type_search.compare_result
   |> List.take_n limit

src/analysis/type_search.ml

@@ -30,7 +30,7 @@
 
 open Std
 
-let type_of env typ =
+let sherlodoc_type_of env typ =
       let open Merlin_sherlodoc in
   let rec aux typ =
     match Types.get_desc typ with
@@ -70,7 +70,10 @@ let doc_to_option = function
   | `Found doc -> Some doc
   | _ -> None
 
-let compare_result (cost_a, a, _, doc_a, _) (cost_b, b, _, doc_b, _) =
+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
@@ -87,10 +90,10 @@ let compute_value
     _ path desc acc =
   let open Merlin_sherlodoc in
   let d = desc.Types.val_type in
-  let typ = type_of env d in
+  let typ = sherlodoc_type_of env d in
   let path = Printtyp.rewrite_double_underscore_paths env path in
-  let path = Format.asprintf "%a" Printtyp.path path in
-  let cost = Query_parser.distance_for query ~path typ in
+  let name = 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 =
@@ -100,11 +103,17 @@ let compute_value
         ~local_defs
         ~comments
         ~pos
-        (`User_input path)
+        (`User_input name)
       |> doc_to_option
     in
-    let constructible = make_constructible path d in
-    (cost, path, desc, doc, constructible) :: acc
+    let loc = desc.Types.val_loc in
+    let typ =
+      Format.asprintf "%a"
+        (Type_utils.Printtyp.type_scheme env)
+        desc.Types.val_type
+    in
+    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
@@ -126,7 +135,15 @@ let values_from_module ctx env lident acc =
   aux acc lident
 
 
-let run ?(limit = 100) config local_defs comments pos env query modules =
+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
   modules
@@ -135,7 +152,7 @@ let run ?(limit = 100) config local_defs comments pos env query modules =
     ~f:(fun acc name ->
         let lident = Longident.Lident name in
         values_from_module ctx env lident acc
-       )
+      )
   |> List.sort ~cmp:compare_result
   |> List.take_n limit
 
@@ -145,4 +162,5 @@ let classify_query query =
   match query.[0] with
   | '+' | '-' -> `Polarity query
   | _ -> `By_type query
-  | exception _ -> `Polarity query
+  | exception (Invalid_argument _) -> `Polarity query
+

src/analysis/type_search.mli

@@ -33,20 +33,21 @@
 (** Compute the list of candidates from a query inside a given environment. *)
 val run :
   ?limit:int ->
-  Mconfig.t ->
-  Mtyper.typedtree ->
-  (string * Location.t) list ->
-  Lexing.position ->
-  Env.t ->
-  Merlin_sherlodoc.Query_parser.t
-  -> string list
-  -> (int * string * Types.value_description * string option * string) list
+  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
+  -> Query_protocol.type_search_result 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 ->
+   Query_protocol.type_search_result ->
+   Query_protocol.type_search_result ->
   int
 
 val classify_query : string -> [ `By_type of string | `Polarity of string ]

src/frontend/query_commands.ml

@@ -474,30 +474,31 @@ 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 result = match Type_search.classify_query query with
+    begin match Type_search.classify_query query with
       | `By_type query ->
-        let query = Merlin_sherlodoc.Query_parser.from_string query in
+        let query = Merlin_sherlodoc.Query.from_string query in
         Type_search.run
-          ~limit config local_defs comments pos env query modules
+          ~limit
+          ~config
+          ~local_defs
+          ~comments
+          ~pos
+          ~env
+          ~query
+          ~modules ()
       | `Polarity query ->
         let query = Polarity_search.prepare_query env query in
-        let dirs = Polarity_search.directories ~global_modules:modules env 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 dirs
-
-    in
-    let verbosity = verbosity pipeline in
-    Printtyp.wrap_printing_env ~verbosity env (fun () ->
-      List.map ~f:(fun (cost, name, typ, doc, constructible) ->
-          let loc = typ.Types.val_loc in
-          let typ =
-            Format.asprintf "%a"
-              (Type_utils.Printtyp.type_scheme env)
-              typ.Types.val_type
-          in
-          { name; typ; cost; loc; doc; constructible}
-        ) result
-      )
+          ~limit
+          ~config
+          ~local_defs
+          ~comments
+          ~pos
+          ~env
+          ~query
+          ~modules ()
+    end
 
   | Refactor_open (mode, pos) ->
     let typer = Mpipeline.typer_result pipeline in

src/sherlodoc/type_expr.mli

@@ -29,12 +29,12 @@
 (** A representation of internal types, with superfluous information removed to
     make it easier to compare them and calculate their distance. *)
 
-(** Type variables are indexed by integers calculated according to the
-    repetition of terms. For example, in the expression of type
-    [‘a -> “b -> ”c], respectively [’a] will have the value [1], [‘b] will have
-    the value [2] and [’c] will have the value [3].
+(** Type variables are indexed by integers calculated according to their
+    positions. For example, in the expression of type ['a -> 'b -> 'c],
+    respectively ['a] will have the value [1], ['b] will have the value [2] and
+    [’c] will have the value [3].
 
-    This makes [‘a -> “b -> ”c] isomorphic to [’foo -> ‘bar -> ’baz]. *)
+    This makes ['a -> 'b -> 'c] isomorphic to [’foo -> 'bar -> 'baz]. *)
 type t =
   | Arrow of t * t
   | Tycon of string * t list

tests/test-units/sherldoc/query_parser_test.ml → tests/test-units/sherldoc/query_test.ml

@@ -8,7 +8,7 @@ let test_distance_1 =
       and candidate = "('a -> 'b) -> 'a list -> 'b list" in
       let expected = 0
       and computed =
-        Query_parser.(
+        Query.(
           distance_for (from_string query) ~path
             (candidate |> Type_expr.from_string |> Option.get))
       in
@@ -22,7 +22,7 @@ let test_distance_2 =
       and candidate = "('a -> 'b) -> 'a list -> 'b list" in
       let expected = 0
       and computed =
-        Query_parser.(
+        Query.(
           distance_for (from_string query) ~path
             (candidate |> Type_expr.from_string |> Option.get))
       in
@@ -36,7 +36,7 @@ let test_distance_3 =
       and candidate = "('a -> 'b) -> 'a list -> 'b list" in
       let expected = 0
       and computed =
-        Query_parser.(
+        Query.(
           distance_for (from_string query) ~path
             (candidate |> Type_expr.from_string |> Option.get))
       in
@@ -50,7 +50,7 @@ let test_distance_4 =
       and candidate = "('a -> 'b) -> 'a list -> 'b list" in
       let expected = 1
       and computed =
-        Query_parser.(
+        Query.(
           distance_for (from_string query) ~path
             (candidate |> Type_expr.from_string |> Option.get))
       in
@@ -64,7 +64,7 @@ let test_distance_5 =
       and candidate = "('a -> 'b) -> 'a list -> 'b list" in
       let expected = 1
       and computed =
-        Query_parser.(
+        Query.(
           distance_for (from_string query) ~path
             (candidate |> Type_expr.from_string |> Option.get))
       in
@@ -78,7 +78,7 @@ let test_distance_6 =
       and candidate = "('a -> 'b) -> 'a list -> 'b list" in
       let expected = 4
       and computed =
-        Query_parser.(
+        Query.(
           distance_for (from_string query) ~path
             (candidate |> Type_expr.from_string |> Option.get))
       in
@@ -92,7 +92,7 @@ let test_distance_7 =
       and candidate = "('a -> 'b) -> 'a list -> 'b list" in
       let expected = 1
       and computed =
-        Query_parser.(
+        Query.(
           distance_for (from_string query) ~path
             (candidate |> Type_expr.from_string |> Option.get))
       in
@@ -106,7 +106,7 @@ let test_distance_8 =
       and candidate = "('a -> 'b) -> 'a list -> 'b list" in
       let expected = 1000
       and computed =
-        Query_parser.(
+        Query.(
           distance_for (from_string query) ~path
             (candidate |> Type_expr.from_string |> Option.get))
       in

tests/test-units/sherldoc/sherlodoc_test.ml

@@ -4,5 +4,5 @@ let () =
       Type_expr_test.cases;
       Name_cost_test.cases;
       Type_distance_test.cases;
-      Query_parser_test.cases;
+      Query_test.cases;
     ]