From 77bbfce57aaa10c2b56c84f90529d84280d4e569 Mon Sep 17 00:00:00 2001 From: xvw Date: Mon, 23 Sep 2024 17:53:29 +0200 Subject: [PATCH] Some refactoring according to @voodoos feedback --- src/analysis/polarity_search.ml | 25 +++++++++--- src/analysis/type_search.ml | 40 ++++++++++++++----- src/analysis/type_search.mli | 21 +++++----- src/frontend/query_commands.ml | 39 +++++++++--------- src/sherlodoc/{query_parser.ml => query.ml} | 0 src/sherlodoc/{query_parser.mli => query.mli} | 0 src/sherlodoc/type_expr.mli | 10 ++--- .../{query_parser_test.ml => query_test.ml} | 16 ++++---- .../{query_parser_test.mli => query_test.mli} | 0 tests/test-units/sherldoc/sherlodoc_test.ml | 2 +- 10 files changed, 93 insertions(+), 60 deletions(-) rename src/sherlodoc/{query_parser.ml => query.ml} (100%) rename src/sherlodoc/{query_parser.mli => query.mli} (100%) rename tests/test-units/sherldoc/{query_parser_test.ml => query_test.ml} (95%) rename tests/test-units/sherldoc/{query_parser_test.mli => query_test.mli} (100%) diff --git a/src/analysis/polarity_search.ml b/src/analysis/polarity_search.ml index 996dc1481..33134221a 100644 --- a/src/analysis/polarity_search.ml +++ b/src/analysis/polarity_search.ml @@ -153,14 +153,21 @@ 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 @@ -168,11 +175,17 @@ let execute_query_as_type_search ~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 diff --git a/src/analysis/type_search.ml b/src/analysis/type_search.ml index 2dd583d5e..30a343849 100644 --- a/src/analysis/type_search.ml +++ b/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 + diff --git a/src/analysis/type_search.mli b/src/analysis/type_search.mli index af89e4ed8..0c28ed383 100644 --- a/src/analysis/type_search.mli +++ b/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 ] diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index 7d14acc9d..9d957cee0 100644 --- a/src/frontend/query_commands.ml +++ b/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 diff --git a/src/sherlodoc/query_parser.ml b/src/sherlodoc/query.ml similarity index 100% rename from src/sherlodoc/query_parser.ml rename to src/sherlodoc/query.ml diff --git a/src/sherlodoc/query_parser.mli b/src/sherlodoc/query.mli similarity index 100% rename from src/sherlodoc/query_parser.mli rename to src/sherlodoc/query.mli diff --git a/src/sherlodoc/type_expr.mli b/src/sherlodoc/type_expr.mli index 67f6e0bcf..ea3cb6382 100644 --- a/src/sherlodoc/type_expr.mli +++ b/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 diff --git a/tests/test-units/sherldoc/query_parser_test.ml b/tests/test-units/sherldoc/query_test.ml similarity index 95% rename from tests/test-units/sherldoc/query_parser_test.ml rename to tests/test-units/sherldoc/query_test.ml index 899227bc0..429dbf9d5 100644 --- a/tests/test-units/sherldoc/query_parser_test.ml +++ b/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 diff --git a/tests/test-units/sherldoc/query_parser_test.mli b/tests/test-units/sherldoc/query_test.mli similarity index 100% rename from tests/test-units/sherldoc/query_parser_test.mli rename to tests/test-units/sherldoc/query_test.mli diff --git a/tests/test-units/sherldoc/sherlodoc_test.ml b/tests/test-units/sherldoc/sherlodoc_test.ml index 7882220b5..a043d98ff 100644 --- a/tests/test-units/sherldoc/sherlodoc_test.ml +++ b/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; ]