From 87eeea0154bd722bd8b4e35bdff50fc43bafdbf1 Mon Sep 17 00:00:00 2001 From: xvw Date: Fri, 20 Sep 2024 23:41:21 +0200 Subject: [PATCH] Rewrite env lookup without Lazy trie --- src/analysis/type_search.ml | 113 ++++++++---------- src/analysis/type_search.mli | 8 +- src/frontend/query_commands.ml | 3 +- ...ch-by-type-comparison-to-polarity-search.t | 8 +- tests/test-dirs/search-by-type.t/run.t | 8 +- 5 files changed, 63 insertions(+), 77 deletions(-) diff --git a/src/analysis/type_search.ml b/src/analysis/type_search.ml index 80d15d7e0..2dd583d5e 100644 --- a/src/analysis/type_search.ml +++ b/src/analysis/type_search.ml @@ -30,10 +30,6 @@ open Std -type trie = - | T of string * Longident.t * t Lazy.t -and t = trie list - let type_of env typ = let open Merlin_sherlodoc in let rec aux typ = @@ -68,25 +64,6 @@ let make_constructible path desc = in path ^ holes -let make_trie env modules = - let rec walk env lident = - Env.fold_modules (fun name _ mdl acc -> - match mdl.Types.md_type with - | Types.Mty_alias _ -> acc - | _ -> - let lident = Longident.Ldot (lident, name) in - T (name, lident, lazy (walk env lident)) :: acc - ) (Some lident) env [] - in - List.fold_left - ~init:[] - ~f:(fun acc name -> - let lident = Longident.Lident name in - match Env.find_module_by_name lident env with - | exception _ -> acc - | _ -> T (name, lident, lazy (walk env lident)) :: acc - ) - modules let doc_to_option = function | `Builtin doc @@ -105,48 +82,64 @@ let compare_result (cost_a, a, _, doc_a, _) (cost_b, b, _, doc_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 -> - let open Merlin_sherlodoc in - let d = desc.Types.val_type in - let typ = 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 - if cost >= 1000 then acc - else - let doc = - Locate.get_doc - ~config - ~env - ~local_defs - ~comments - ~pos - (`User_input path) - |> doc_to_option - in - let constructible = make_constructible path d in - (cost, path, desc, doc, constructible) :: acc - ) dir env acc - in - let rec walk acc (T (_, dir, children)) = - let force () = - let _ = Env.find_module_by_name dir env in - Lazy.force children +let compute_value + (config, local_defs, comments, pos, query) env + _ path desc acc = + let open Merlin_sherlodoc in + let d = desc.Types.val_type in + let typ = 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 + if cost >= 1000 then acc + else + let doc = + Locate.get_doc + ~config + ~env + ~local_defs + ~comments + ~pos + (`User_input path) + |> doc_to_option in - match force () with - | computed_children -> - let init = fold_values (Some dir) acc in - List.fold_left ~init ~f:walk computed_children + let constructible = make_constructible path d in + (cost, path, desc, doc, constructible) :: acc + +let compute_values ctx env lident acc = + Env.fold_values (compute_value ctx env) lident env acc + +let values_from_module ctx 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 + 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 - let init = fold_values None [] in - trie - |> List.fold_left ~init ~f:walk + 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 + modules + |> List.fold_left + ~init + ~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 - + + let classify_query query = let query = String.trim query in match query.[0] with diff --git a/src/analysis/type_search.mli b/src/analysis/type_search.mli index f8b02e045..af89e4ed8 100644 --- a/src/analysis/type_search.mli +++ b/src/analysis/type_search.mli @@ -30,12 +30,6 @@ (** Search by type in the current environment. *) -(** A Lazy trie of the potentials values. *) -type t - -(** Initialize the trie with a given list of directories. *) -val make_trie : Env.t -> string list -> t - (** Compute the list of candidates from a query inside a given environment. *) val run : ?limit:int -> @@ -45,7 +39,7 @@ val run : Lexing.position -> Env.t -> Merlin_sherlodoc.Query_parser.t - -> t + -> string list -> (int * string * Types.value_description * string option * string) list val doc_to_option : [> `Builtin of string | `Found of string ] -> string option diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index 583b0018c..7d14acc9d 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -477,9 +477,8 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = 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 + ~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 diff --git a/tests/test-dirs/search-by-type-comparison-to-polarity-search.t b/tests/test-dirs/search-by-type-comparison-to-polarity-search.t index 0654dbb1f..31048d7aa 100644 --- a/tests/test-dirs/search-by-type-comparison-to-polarity-search.t +++ b/tests/test-dirs/search-by-type-comparison-to-polarity-search.t @@ -16,14 +16,14 @@ potential failures, so lifting the result in an int option). "name": "int_of_string_opt", "type": "string -> int option" } - { - "name": "Int32.of_string_opt", - "type": "string -> int32 option" - } { "name": "Int64.of_string_opt", "type": "string -> int64 option" } + { + "name": "Int32.of_string_opt", + "type": "string -> int32 option" + } { "name": "Sys.getenv_opt", "type": "string -> string option" diff --git a/tests/test-dirs/search-by-type.t/run.t b/tests/test-dirs/search-by-type.t/run.t index ac5d162a6..e9f36f47f 100644 --- a/tests/test-dirs/search-by-type.t/run.t +++ b/tests/test-dirs/search-by-type.t/run.t @@ -14,14 +14,14 @@ "doc": "Convert the given string to an integer. The string is read in decimal (by default, or if the string begins with [0u]), in hexadecimal (if it begins with [0x] or [0X]), in octal (if it begins with [0o] or [0O]), or in binary (if it begins with [0b] or [0B]). The [0u] prefix reads the input as an unsigned integer in the range [[0, 2*max_int+1]]. If the input exceeds {!max_int} it is converted to the signed integer [min_int + input - max_int - 1]. The [_] (underscore) character can appear anywhere in the string and is ignored. Return [None] if the given string is not a valid representation of an integer, or if the integer represented exceeds the range of integers representable in type [int]. @since 4.05" } { - "name": "Int32.of_string_opt", - "type": "string -> int32 option", + "name": "Int64.of_string_opt", + "type": "string -> int64 option", "cost": 2, "doc": "Same as [of_string], but return [None] instead of raising. @since 4.05" } { - "name": "Int64.of_string_opt", - "type": "string -> int64 option", + "name": "Int32.of_string_opt", + "type": "string -> int32 option", "cost": 2, "doc": "Same as [of_string], but return [None] instead of raising. @since 4.05" }