From ce98788096badee5f9aaa88aa99a27778c2e4638 Mon Sep 17 00:00:00 2001 From: xvw Date: Fri, 6 Sep 2024 15:53:39 +0200 Subject: [PATCH 01/24] Initialize merlin-lib.sherlodoc --- .ocamlformat-enable | 1 + src/sherlodoc/dune | 5 +++++ 2 files changed, 6 insertions(+) create mode 100644 .ocamlformat-enable create mode 100644 src/sherlodoc/dune diff --git a/.ocamlformat-enable b/.ocamlformat-enable new file mode 100644 index 000000000..479c6dc5c --- /dev/null +++ b/.ocamlformat-enable @@ -0,0 +1 @@ +src/sherlodoc/** \ No newline at end of file diff --git a/src/sherlodoc/dune b/src/sherlodoc/dune new file mode 100644 index 000000000..5dae7831d --- /dev/null +++ b/src/sherlodoc/dune @@ -0,0 +1,5 @@ +(library + (name merlin_sherlodoc) + (public_name merlin-lib.sherlodoc)) + +(ocamllex query_lexer) From f8c78838c95f98b4356664147ff908727ada3e67 Mon Sep 17 00:00:00 2001 From: xvw Date: Mon, 9 Sep 2024 17:10:03 +0200 Subject: [PATCH 02/24] Introduce `merlin-lib.sherlodoc` Core search engine by type, strongly inspired by https://doc.sherlocode.com/. The library is globally dependency agnostic so that it can potentially be used one day as a base for other applications. --- merlin-lib.opam | 1 + src/sherlodoc/dune | 6 +- src/sherlodoc/name_cost.ml | 102 +++++++++++++++++ src/sherlodoc/name_cost.mli | 42 +++++++ src/sherlodoc/query_parser.ml | 94 ++++++++++++++++ src/sherlodoc/query_parser.mli | 46 ++++++++ src/sherlodoc/type_distance.ml | 187 ++++++++++++++++++++++++++++++++ src/sherlodoc/type_distance.mli | 33 ++++++ src/sherlodoc/type_expr.ml | 137 +++++++++++++++++++++++ src/sherlodoc/type_expr.mli | 53 +++++++++ src/sherlodoc/type_lexer.mll | 15 +++ src/sherlodoc/type_parsed.ml | 40 +++++++ src/sherlodoc/type_parsed.mli | 44 ++++++++ src/sherlodoc/type_parser.mly | 52 +++++++++ src/sherlodoc/type_polarity.ml | 48 ++++++++ src/sherlodoc/type_polarity.mli | 49 +++++++++ 16 files changed, 948 insertions(+), 1 deletion(-) create mode 100644 src/sherlodoc/name_cost.ml create mode 100644 src/sherlodoc/name_cost.mli create mode 100644 src/sherlodoc/query_parser.ml create mode 100644 src/sherlodoc/query_parser.mli create mode 100644 src/sherlodoc/type_distance.ml create mode 100644 src/sherlodoc/type_distance.mli create mode 100644 src/sherlodoc/type_expr.ml create mode 100644 src/sherlodoc/type_expr.mli create mode 100644 src/sherlodoc/type_lexer.mll create mode 100644 src/sherlodoc/type_parsed.ml create mode 100644 src/sherlodoc/type_parsed.mli create mode 100644 src/sherlodoc/type_parser.mly create mode 100644 src/sherlodoc/type_polarity.ml create mode 100644 src/sherlodoc/type_polarity.mli diff --git a/merlin-lib.opam b/merlin-lib.opam index c78fbd3fb..153285c7c 100644 --- a/merlin-lib.opam +++ b/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"} diff --git a/src/sherlodoc/dune b/src/sherlodoc/dune index 5dae7831d..bb11c8c41 100644 --- a/src/sherlodoc/dune +++ b/src/sherlodoc/dune @@ -2,4 +2,8 @@ (name merlin_sherlodoc) (public_name merlin-lib.sherlodoc)) -(ocamllex query_lexer) +(menhir + (modules type_parser) + (flags --explain)) + +(ocamllex type_lexer) diff --git a/src/sherlodoc/name_cost.ml b/src/sherlodoc/name_cost.ml new file mode 100644 index 000000000..5142fd49e --- /dev/null +++ b/src/sherlodoc/name_cost.ml @@ -0,0 +1,102 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2024 Xavier Van de Woestyne + Arthur Wendling + + + 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. + + )* }}} *) + +let distance ?cutoff a b = + let len_a = String.length a and len_b = String.length b in + let cutoff = + let v = Int.max len_a len_b in + Option.fold ~none:v ~some:(Int.min v) cutoff + in + if abs (len_a - len_b) > cutoff then None + else + let matrix = Array.make_matrix (succ len_a) (succ len_b) (succ cutoff) in + let () = matrix.(0).(0) <- 0 in + let () = + for i = 1 to len_a do + matrix.(i).(0) <- i + done + in + let () = + for j = 1 to len_b do + matrix.(0).(j) <- j + done + in + let () = + for i = 1 to len_a do + for j = Int.max 1 (i - cutoff - 1) to Int.min len_b (i + cutoff + 1) do + let cost = if Char.equal a.[i - 1] b.[j - 1] then 0 else 1 in + let best = + Int.min + (1 + Int.min matrix.(i - 1).(j) matrix.(i).(j - 1)) + (matrix.(i - 1).(j - 1) + cost) + in + let best = + if + not + (i > i && j > 1 + && Char.equal a.[i - 1] b.[j - 2] + && Char.equal a.[i - 2] b.[j - 1]) + then best + else Int.min best (matrix.(i - 2).(j - 2) + cost) + in + matrix.(i).(j) <- best + done + done + in + let final_result = matrix.(len_a).(len_b) in + if final_result > cutoff then None else Some final_result + +let distance_of_substring ?cutoff query entry = + let len_e = String.length entry in + let len_q = String.length query in + let rec aux acc i = + if i = len_e then acc + else + let s = len_q |> Int.min (len_e - i) |> String.sub entry i in + let d = distance ?cutoff query s in + match (d, acc) with + | Some 0, _ -> Some 0 + | Some x, Some y -> aux (Some (Int.min (x * 4) y)) (succ i) + | Some x, _ | _, Some x -> aux (Some x) (succ i) + | None, None -> aux None (succ i) + in + let exact_match e = e + (abs (len_e - len_q) / 4) in + aux None 0 |> Option.map exact_match + +let best_distance ?cutoff words entry = + let rec aux acc = function + | [] -> acc |> Option.value ~default:0 + | x :: xs -> ( + match distance_of_substring ?cutoff x entry with + | None -> aux acc xs + | Some 0 -> 0 + | Some x -> + let acc = Int.min x (Option.value ~default:x acc) in + aux (Some acc) xs) + in + aux None words diff --git a/src/sherlodoc/name_cost.mli b/src/sherlodoc/name_cost.mli new file mode 100644 index 000000000..f3be04b29 --- /dev/null +++ b/src/sherlodoc/name_cost.mli @@ -0,0 +1,42 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2024 Xavier Van de Woestyne + Arthur Wendling + + + 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. + + )* }}} *) + +(** Utilities for calculating distances between names. *) + +val distance : ?cutoff:int -> string -> string -> int option +(** [distance ?cutoff a b] returns the + {{:https://en.wikipedia.org/wiki/Damerau%E2%80%93Levenshtein_distance} + Damerau-Levenshtein} between [a] and [b]. *) + +val distance_of_substring : ?cutoff:int -> string -> string -> int option +(** [distance_of_substring ?cutoff a b] compute the distance by extracting + relevant substring from [b] *) + +val best_distance : ?cutoff:int -> string list -> string -> int +(** [best_distance ?cutoff words entry] compute the best distance of a list of + string according to a given string. *) diff --git a/src/sherlodoc/query_parser.ml b/src/sherlodoc/query_parser.ml new file mode 100644 index 000000000..04e07beba --- /dev/null +++ b/src/sherlodoc/query_parser.ml @@ -0,0 +1,94 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2024 Xavier Van de Woestyne + Arthur Wendling + + + 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. + + )* }}} *) + +type t = { words : string list; type_expr : Type_expr.t option } + +let equal { words = words_a; type_expr = type_expr_a } + { words = words_b; type_expr = type_expr_b } = + List.equal String.equal words_a words_b + && Option.equal Type_expr.equal type_expr_a type_expr_b + +let to_string { words; type_expr } = + let words = String.concat "; " words in + let type_expr = + type_expr + |> Option.map Type_expr.to_string + |> Option.value ~default:"" + in + "[" ^ words ^ "] " ^ type_expr + +let balance_parens len str = + let rec aux i open_parens close_parens = + if i >= len then (open_parens, close_parens) + else + match str.[i] with + | '(' -> aux (succ i) (succ open_parens) close_parens + | ')' when open_parens > 0 -> aux (succ i) (pred open_parens) close_parens + | ')' -> aux (succ i) open_parens (succ close_parens) + | _ -> aux (succ i) open_parens close_parens + in + let o, c = aux 0 0 0 in + let o = String.make c '(' and c = String.make o ')' in + o ^ str ^ c + +let naive_of_string str = + str |> String.split_on_char ' ' + |> List.filter (fun s -> not (String.equal s String.empty)) + +let guess_type_search len str = + len >= 1 + && (Char.equal str.[0] '\'' + || String.contains str '-' || String.contains str '(') + +let from_string str = + let len = String.length str in + let words, type_expr = + match String.index_opt str ':' with + | None -> + if guess_type_search len str then + let str = balance_parens len str in + ("", Type_expr.from_string str) + else (str, None) + | Some loc -> + let str_name = String.sub str 0 loc + and str_type = String.sub str (succ loc) (len - loc - 1) in + let len = String.length str_type in + let str_type = balance_parens len str_type in + (str_name, Type_expr.from_string str_type) + in + let words = naive_of_string words in + { words; type_expr } + +let distance_for { words; type_expr } ~path candidate = + let type_cost = + type_expr + |> Option.map (fun query -> Type_distance.compute ~query ~entry:candidate) + |> Option.value ~default:0 + in + let name_cost = Name_cost.best_distance words path in + name_cost + type_cost diff --git a/src/sherlodoc/query_parser.mli b/src/sherlodoc/query_parser.mli new file mode 100644 index 000000000..cc98c8cc6 --- /dev/null +++ b/src/sherlodoc/query_parser.mli @@ -0,0 +1,46 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2024 Xavier Van de Woestyne + Arthur Wendling + + + 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. + + )* }}} *) + +(** Prepares a query based on a string of characters. A query acts on the + identifier of a function and its type.. *) + +type t = { words : string list; type_expr : Type_expr.t option } +(** Describes a search on an identifier and a type. *) + +val from_string : string -> t +(** Converts a string into a search query. *) + +val to_string : t -> string +(** Inspect a query (mostly for debugging purpose). *) + +val equal : t -> t -> bool +(** Equality between queries. *) + +val distance_for : t -> path:string -> Type_expr.t -> int +(** [distance_for query ~path typexpr] returns a score for a [query] observing a + given value, (a [path] and a [type_expr]). *) diff --git a/src/sherlodoc/type_distance.ml b/src/sherlodoc/type_distance.ml new file mode 100644 index 000000000..a514be01d --- /dev/null +++ b/src/sherlodoc/type_distance.ml @@ -0,0 +1,187 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2024 Xavier Van de Woestyne + Arthur Wendling + + + 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. + + )* }}} *) + +type step = + | Wildcard + | Tyname of string + | Tyvar of int + | Left_arrow + | Right_arrow + | Product of { position : int; length : int } + | Argument of { position : int; length : int } + +module P = Type_polarity + +let make_path t = + let rec aux prefix = function + | Type_expr.Unhandled -> [] + | Type_expr.Wildcard -> [ Wildcard :: prefix ] + | Type_expr.Tyvar x -> [ Tyvar x :: prefix ] + | Type_expr.Arrow (a, b) -> + List.rev_append + (aux (Left_arrow :: prefix) a) + (aux (Right_arrow :: prefix) b) + | Type_expr.Tycon (constr, []) -> [ Tyname constr :: prefix ] + | Type_expr.Tycon (constr, args) -> + let length = String.length constr in + args + |> List.mapi (fun position arg -> + let prefix = Argument { position; length } :: prefix in + aux prefix arg) + |> List.fold_left (fun acc xs -> List.rev_append xs acc) [] + | Type_expr.Tuple args -> + let length = List.length args in + args + |> List.mapi (fun position arg -> + let prefix = Product { position; length } :: prefix in + aux prefix arg) + |> List.fold_left (fun acc xs -> List.rev_append xs acc) [] + in + List.map List.rev (aux [] t) + +let make_cache xs ys = + let h = List.length xs |> succ + and w = List.length ys |> succ + and not_used = -1 in + Array.make_matrix h w not_used + +let skip_entry = 10 +let max_distance = 10_000 + +let distance xs ys = + let cache = make_cache xs ys in + let rec memo ~xpolarity ~ypolarity i j xs ys = + let cell = cache.(i).(j) in + if cell >= 0 then cell + else + let value = aux ~xpolarity ~ypolarity i j xs ys in + let () = cache.(i).(j) <- value in + value + and aux ~xpolarity ~ypolarity i j xs ys = + match (xs, ys) with + | [], _ -> 0 + | [ Wildcard ], _ -> 0 + | _, [] -> max_distance + | [ Tyvar _ ], [ Wildcard ] when P.equal xpolarity ypolarity -> 0 + | [ Tyvar x ], [ Tyvar y ] when P.equal xpolarity ypolarity -> + if Int.equal x y then 0 else 1 + | Left_arrow :: xs, Left_arrow :: ys -> + let xpolarity = P.negate xpolarity and ypolarity = P.negate ypolarity in + memo ~xpolarity ~ypolarity (succ i) (succ j) xs ys + | Left_arrow :: xs, _ -> + let xpolarity = P.negate xpolarity in + memo ~xpolarity ~ypolarity (succ i) j xs ys + | _, Left_arrow :: ys -> + let ypolarity = P.negate ypolarity in + memo ~xpolarity ~ypolarity i (succ j) xs ys + | _, Right_arrow :: ys -> memo ~xpolarity ~ypolarity i (succ j) xs ys + | Right_arrow :: xs, _ -> memo ~xpolarity ~ypolarity (succ i) j xs ys + | Product { length = a; _ } :: xs, Product { length = b; _ } :: ys + | Argument { length = a; _ } :: xs, Argument { length = b; _ } :: ys -> + let l = abs (a - b) in + l + memo ~xpolarity ~ypolarity (succ i) (succ j) xs ys + | Product _ :: xs, ys -> 1 + memo ~xpolarity ~ypolarity (succ i) j xs ys + | xs, Product _ :: ys -> 1 + memo ~xpolarity ~ypolarity i (succ j) xs ys + | Tyname x :: xs', Tyname y :: ys' when P.equal xpolarity ypolarity -> ( + match Name_cost.distance x y with + | None -> skip_entry + memo ~xpolarity ~ypolarity i (succ j) xs ys' + | Some cost -> + cost + memo ~xpolarity ~ypolarity (succ i) (succ j) xs' ys') + | xs, Tyname _ :: ys -> + skip_entry + memo ~xpolarity ~ypolarity i (succ j) xs ys + | xs, Argument _ :: ys -> memo ~xpolarity ~ypolarity i (succ j) xs ys + | _, (Wildcard | Tyvar _) :: _ -> max_distance + in + + let positive = P.positive in + aux ~xpolarity:positive ~ypolarity:positive 0 0 xs ys + +let make_array list = + list |> Array.of_list + |> Array.map (fun li -> + let li = List.mapi (fun i x -> (x, i)) li in + List.sort Stdlib.compare li) + +let init_heuristic list = + let used = Array.make List.(length @@ hd list) false in + let arr = make_array list in + let h = Array.make (succ @@ Array.length arr) 0 in + let () = Array.sort Stdlib.compare arr in + let () = + for i = Array.length h - 2 downto 0 do + let best = fst @@ List.hd arr.(i) in + h.(i) <- h.(i + 1) + best + done + in + (used, arr, h) + +let replace_score best score = best := Int.min score !best + +let minimize = function + | [] -> 0 + | list -> + let used, arr, heuristics = init_heuristic list in + let best = ref 1000 and limit = ref 0 in + let len_a = Array.length arr in + let rec aux rem acc i = + let () = incr limit in + if !limit > max_distance then false + else if rem <= 0 then + let score = acc + (1000 * (len_a - i)) in + let () = replace_score best score in + true + else if i >= len_a then + let score = acc + (5 * rem) in + let () = replace_score best score in + true + else if acc + heuristics.(i) >= !best then true + else + let rec find = function + | [] -> true + | (cost, j) :: rest -> + let continue = + if used.(j) then true + else + let () = used.(j) <- true in + let continue = aux (pred rem) (acc + cost) (succ i) in + let () = used.(j) <- false in + continue + in + if continue then find rest else false + in + find arr.(i) + in + let _ = aux (Array.length used) 0 0 in + !best + +let compute ~query ~entry = + let query = make_path query in + let path = make_path entry in + match (path, query) with + | _, [] | [], _ -> 1000 + | _ -> query |> List.map (fun p -> List.map (distance p) path) |> minimize diff --git a/src/sherlodoc/type_distance.mli b/src/sherlodoc/type_distance.mli new file mode 100644 index 000000000..89e884bc3 --- /dev/null +++ b/src/sherlodoc/type_distance.mli @@ -0,0 +1,33 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2024 Xavier Van de Woestyne + Arthur Wendling + + + 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. + + )* }}} *) + +(** Calculate an approximation of the distance between two types. *) + +val compute : query:Type_expr.t -> entry:Type_expr.t -> int +(** [compute a b] calculates an approximation of the distance between [query] + and [entry]. *) diff --git a/src/sherlodoc/type_expr.ml b/src/sherlodoc/type_expr.ml new file mode 100644 index 000000000..83765c2e8 --- /dev/null +++ b/src/sherlodoc/type_expr.ml @@ -0,0 +1,137 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2024 Xavier Van de Woestyne + Arthur Wendling + + + 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. + + )* }}} *) + +type t = + | Arrow of t * t + | Tycon of string * t list + | Tuple of t list + | Tyvar of int + | Wildcard + | Unhandled + +let rec equal a b = + match (a, b) with + | Unhandled, Unhandled | Wildcard, Wildcard -> true + | Tyvar a, Tyvar b -> Int.equal a b + | Tuple a, Tuple b -> List.equal equal a b + | Tycon (ka, a), Tycon (kb, b) -> String.equal ka kb && List.equal equal a b + | Arrow (ia, oa), Arrow (ib, ob) -> equal ia ib && equal oa ob + | Arrow (_, _), _ + | Tycon (_, _), _ + | Tuple _, _ + | Tyvar _, _ + | Wildcard, _ + | Unhandled, _ -> false + +let parens x = "(" ^ x ^ ")" + +let tyvar_to_string x = + let rec aux acc i = + let c = Char.code 'a' + (i mod 26) |> Char.chr in + let acc = acc ^ String.make 1 c in + if i < 26 then acc else aux acc (i - 26) + in + aux "'" x + +let unhandled = "?" + +let rec to_string = function + | Unhandled -> unhandled + | Wildcard -> "_" + | Tyvar i -> tyvar_to_string i + | Tycon (constr, []) -> constr + | Tycon (constr, [ x ]) -> with_parens x ^ " " ^ constr + | Tycon (constr, xs) -> (xs |> as_list "" |> parens) ^ " " ^ constr + | Tuple xs -> as_tuple "" xs + | Arrow (a, b) -> with_parens a ^ " -> " ^ to_string b + +and with_parens = function + | (Arrow _ | Tuple _) as t -> t |> to_string |> parens + | t -> to_string t + +and as_list acc = function + | [] -> acc ^ unhandled + | [ x ] -> acc ^ to_string x + | x :: xs -> + let acc = acc ^ to_string x ^ ", " in + as_list acc xs + +and as_tuple acc = function + | [] -> acc ^ unhandled + | [ x ] -> acc ^ with_parens x + | x :: xs -> + let acc = acc ^ with_parens x ^ " * " in + as_tuple acc xs + +module SMap = Map.Make (String) + +let map_with_state f i map list = + let i, map, r = + list + |> List.fold_left + (fun (i, map, acc) x -> + let i, map, elt = f i map x in + (i, map, elt :: acc)) + (i, map, []) + in + (i, map, List.rev r) + +let normalize_type_parameters ty = + let rec aux i map = function + | Type_parsed.Unhandled -> (i, map, Unhandled) + | Type_parsed.Wildcard -> (i, map, Wildcard) + | Type_parsed.Arrow (a, b) -> + let i, map, a = aux i map a in + let i, map, b = aux i map b in + (i, map, Arrow (a, b)) + | Type_parsed.Tycon (s, r) -> + let i, map, r = map_with_state aux i map r in + (i, map, Tycon (s, r)) + | Type_parsed.Tuple r -> + let i, map, r = map_with_state aux i map r in + (i, map, Tuple r) + | Type_parsed.Tyvar var -> + let i, map, value = + match SMap.find_opt var map with + | Some value -> (i, map, value) + | None -> + let i = succ i in + let map = SMap.add var i map in + (i, map, i) + in + (i, map, Tyvar value) + in + let _, _, normalized = aux ~-1 SMap.empty ty in + normalized + +let from_string str = + try + str |> Lexing.from_string + |> Type_parser.main Type_lexer.token + |> normalize_type_parameters |> Option.some + with _ -> None diff --git a/src/sherlodoc/type_expr.mli b/src/sherlodoc/type_expr.mli new file mode 100644 index 000000000..03c1af7cd --- /dev/null +++ b/src/sherlodoc/type_expr.mli @@ -0,0 +1,53 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2024 Xavier Van de Woestyne + Arthur Wendling + + + 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. + + )* }}} *) + +(** 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]. + + This makes [‘a -> “b -> ”c] isomorphic to [’foo -> ‘bar -> ’baz]. *) +type t = + | Arrow of t * t + | Tycon of string * t list + | Tuple of t list + | Tyvar of int + | Wildcard + | Unhandled + +val from_string : string -> t option +(** Try deserializing a string into a typed expression. *) + +val to_string : t -> string +(** Render a type to a string. *) + +val equal : t -> t -> bool +(** Equality between types *) diff --git a/src/sherlodoc/type_lexer.mll b/src/sherlodoc/type_lexer.mll new file mode 100644 index 000000000..b1c798f22 --- /dev/null +++ b/src/sherlodoc/type_lexer.mll @@ -0,0 +1,15 @@ +{ + open Type_parser +} + +rule token = parse +| ' ' { token lexbuf } +| "->" { ARROW } +| "(" { PARENS_OPEN } +| ")" { PARENS_CLOSE } +| "," { COMMA } +| '_' { WILDCARD } +| '*' { STAR } +| "'" (['a'-'z' 'A'-'Z' '0'-'9' '\'' '_']* as p) { POLY p } +| ['a'-'z' 'A'-'Z' '0'-'9' '\'' '_' '.']+ as w { WORD w } +| eof { EOF } \ No newline at end of file diff --git a/src/sherlodoc/type_parsed.ml b/src/sherlodoc/type_parsed.ml new file mode 100644 index 000000000..2a99c81cd --- /dev/null +++ b/src/sherlodoc/type_parsed.ml @@ -0,0 +1,40 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2024 Xavier Van de Woestyne + Arthur Wendling + + + 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. + + )* }}} *) + +type t = + | Arrow of t * t + | Tycon of string * t list + | Tuple of t list + | Tyvar of string + | Wildcard + | Unhandled + +let tuple = function + | [] -> Tycon ("unit", []) + | [ x ] -> x + | xs -> Tuple xs diff --git a/src/sherlodoc/type_parsed.mli b/src/sherlodoc/type_parsed.mli new file mode 100644 index 000000000..a4f62d120 --- /dev/null +++ b/src/sherlodoc/type_parsed.mli @@ -0,0 +1,44 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2024 Xavier Van de Woestyne + Arthur Wendling + + + 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. + + )* }}} *) + +(** A parsed type expression representation, where type variables are expressed + as strings and must be normalized in a {!type:Type_expr.t}. *) + +type t = + | Arrow of t * t + | Tycon of string * t list + | Tuple of t list + | Tyvar of string + | Wildcard + | Unhandled + +val tuple : t list -> t +(** Create a tuple using a rather naive heuristic: + - If the list is empty, it produces a type [unit] + - If the list contains only one element, that element is returned + - Otherwise, a tuple is constructed. *) diff --git a/src/sherlodoc/type_parser.mly b/src/sherlodoc/type_parser.mly new file mode 100644 index 000000000..a3c4a6bc7 --- /dev/null +++ b/src/sherlodoc/type_parser.mly @@ -0,0 +1,52 @@ +%token EOF +%token PARENS_OPEN PARENS_CLOSE +%token ARROW COMMA WILDCARD STAR +%token WORD +%token POLY + +%start main +%type main + +%% + +main: + | t=typ EOF { t } +; + +typ: + | t=typ2 { t } + | a=typ2 ARROW b=typ { Type_parsed.Arrow (a, b) } +; + +typ2: + | xs=list1(typ1, STAR) { Type_parsed.tuple xs } + ; + +typ1: + | { Type_parsed.Wildcard } + | ts=typs { Type_parsed.tuple ts } + | ts=typs w=WORD ws=list(WORD) + { + List.fold_left ( fun acc w -> + Type_parsed.Tycon (w, [acc])) (Type_parsed.Tycon (w, ts)) ws + } +; + +typ0: + | WILDCARD { Type_parsed.Wildcard } + | w=POLY { Type_parsed.Tyvar w } + | w=WORD { Type_parsed.Tycon (w, []) } +; + + +typs: + | t=typ0 { [t] } + | PARENS_OPEN ts=list1(typ, COMMA) PARENS_CLOSE { ts } +; + + +list1(term, separator): + | x=term { [x] } + | x=term separator xs=list1(term, separator) { x::xs } +; + diff --git a/src/sherlodoc/type_polarity.ml b/src/sherlodoc/type_polarity.ml new file mode 100644 index 000000000..2be3949fc --- /dev/null +++ b/src/sherlodoc/type_polarity.ml @@ -0,0 +1,48 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2024 Xavier Van de Woestyne + Arthur Wendling + + + 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. + + )* }}} *) + +type t = Positive | Negative + +let positive = Positive +let negative = Negative + +let negate = function + | Positive -> Negative + | Negative -> Positive + +let to_string = function + | Negative -> "negative" + | Positive -> "positive" + +let compare a b = + match (a, b) with + | Negative, Positive -> -1 + | Positive, Negative -> 1 + | Positive, Positive | Negative, Negative -> 0 + +let equal a b = Int.equal 0 (compare a b) diff --git a/src/sherlodoc/type_polarity.mli b/src/sherlodoc/type_polarity.mli new file mode 100644 index 000000000..e77d292bf --- /dev/null +++ b/src/sherlodoc/type_polarity.mli @@ -0,0 +1,49 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2024 Xavier Van de Woestyne + Arthur Wendling + + + 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. + + )* }}} *) + +(** Describes the polarity sign of a type [negative] for contravariant + parameters and [positive] for covariant parameters (the return of the + function). *) + +type t + +val positive : t +val negative : t + +val negate : t -> t +(** [negate x] returns [positive] if [x] is [negative] and [negative] if [x] is + [positive]. *) + +val equal : t -> t -> bool +(** Equality between polarity sign. *) + +val compare : t -> t -> int +(** A comparison that act that [negative < positive]. *) + +val to_string : t -> string +(** Simple printer for polarity sign. *) From 3a47504b84ef99f9f8513d80dc48c0948aa2cf14 Mon Sep 17 00:00:00 2001 From: xvw Date: Mon, 9 Sep 2024 17:12:14 +0200 Subject: [PATCH 03/24] Introduce unit-tests (sherlodoc) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Currently, Merlin's code base only uses test CRAMs, although some functions are easier to maintain if they are unit-tested. It is therefore a ‘gradual’ introduction of unit tests into the code base. --- .ocamlformat-enable | 3 +- src/analysis/dune | 1 + src/sherlodoc/name_cost.ml | 2 +- src/sherlodoc/name_cost.mli | 2 +- src/sherlodoc/query_parser.ml | 2 +- src/sherlodoc/query_parser.mli | 2 +- src/sherlodoc/type_distance.ml | 2 +- src/sherlodoc/type_distance.mli | 2 +- src/sherlodoc/type_expr.ml | 2 +- src/sherlodoc/type_expr.mli | 2 +- src/sherlodoc/type_parsed.ml | 2 +- src/sherlodoc/type_parsed.mli | 2 +- src/sherlodoc/type_polarity.ml | 2 +- src/sherlodoc/type_polarity.mli | 2 +- tests/test-units/sherldoc/dune | 3 + tests/test-units/sherldoc/name_cost_test.ml | 126 +++++++++++++++ tests/test-units/sherldoc/name_cost_test.mli | 1 + .../test-units/sherldoc/query_parser_test.ml | 126 +++++++++++++++ .../test-units/sherldoc/query_parser_test.mli | 1 + tests/test-units/sherldoc/sherlodoc_test.ml | 8 + .../test-units/sherldoc/type_distance_test.ml | 45 ++++++ .../sherldoc/type_distance_test.mli | 1 + tests/test-units/sherldoc/type_expr_test.ml | 146 ++++++++++++++++++ tests/test-units/sherldoc/type_expr_test.mli | 1 + 24 files changed, 473 insertions(+), 13 deletions(-) create mode 100644 tests/test-units/sherldoc/dune create mode 100644 tests/test-units/sherldoc/name_cost_test.ml create mode 100644 tests/test-units/sherldoc/name_cost_test.mli create mode 100644 tests/test-units/sherldoc/query_parser_test.ml create mode 100644 tests/test-units/sherldoc/query_parser_test.mli create mode 100644 tests/test-units/sherldoc/sherlodoc_test.ml create mode 100644 tests/test-units/sherldoc/type_distance_test.ml create mode 100644 tests/test-units/sherldoc/type_distance_test.mli create mode 100644 tests/test-units/sherldoc/type_expr_test.ml create mode 100644 tests/test-units/sherldoc/type_expr_test.mli diff --git a/.ocamlformat-enable b/.ocamlformat-enable index 479c6dc5c..a4c62a180 100644 --- a/.ocamlformat-enable +++ b/.ocamlformat-enable @@ -1 +1,2 @@ -src/sherlodoc/** \ No newline at end of file +src/sherlodoc/** +tests/test-units/** \ No newline at end of file diff --git a/src/analysis/dune b/src/analysis/dune index 905df41c6..f19629e87 100644 --- a/src/analysis/dune +++ b/src/analysis/dune @@ -19,6 +19,7 @@ merlin_kernel merlin_utils merlin_index_format + merlin_sherlodoc ocaml_parsing ocaml_preprocess query_protocol diff --git a/src/sherlodoc/name_cost.ml b/src/sherlodoc/name_cost.ml index 5142fd49e..ef2dd143a 100644 --- a/src/sherlodoc/name_cost.ml +++ b/src/sherlodoc/name_cost.ml @@ -3,7 +3,7 @@ This file is part of Merlin, an helper for ocaml editors Copyright (C) 2013 - 2024 Xavier Van de Woestyne - Arthur Wendling + Arthur Wendling Permission is hereby granted, free of charge, to any person obtaining a diff --git a/src/sherlodoc/name_cost.mli b/src/sherlodoc/name_cost.mli index f3be04b29..28f943fca 100644 --- a/src/sherlodoc/name_cost.mli +++ b/src/sherlodoc/name_cost.mli @@ -3,7 +3,7 @@ This file is part of Merlin, an helper for ocaml editors Copyright (C) 2013 - 2024 Xavier Van de Woestyne - Arthur Wendling + Arthur Wendling Permission is hereby granted, free of charge, to any person obtaining a diff --git a/src/sherlodoc/query_parser.ml b/src/sherlodoc/query_parser.ml index 04e07beba..121c538b5 100644 --- a/src/sherlodoc/query_parser.ml +++ b/src/sherlodoc/query_parser.ml @@ -3,7 +3,7 @@ This file is part of Merlin, an helper for ocaml editors Copyright (C) 2013 - 2024 Xavier Van de Woestyne - Arthur Wendling + Arthur Wendling Permission is hereby granted, free of charge, to any person obtaining a diff --git a/src/sherlodoc/query_parser.mli b/src/sherlodoc/query_parser.mli index cc98c8cc6..71999ff8b 100644 --- a/src/sherlodoc/query_parser.mli +++ b/src/sherlodoc/query_parser.mli @@ -3,7 +3,7 @@ This file is part of Merlin, an helper for ocaml editors Copyright (C) 2013 - 2024 Xavier Van de Woestyne - Arthur Wendling + Arthur Wendling Permission is hereby granted, free of charge, to any person obtaining a diff --git a/src/sherlodoc/type_distance.ml b/src/sherlodoc/type_distance.ml index a514be01d..435ab6b8e 100644 --- a/src/sherlodoc/type_distance.ml +++ b/src/sherlodoc/type_distance.ml @@ -3,7 +3,7 @@ This file is part of Merlin, an helper for ocaml editors Copyright (C) 2013 - 2024 Xavier Van de Woestyne - Arthur Wendling + Arthur Wendling Permission is hereby granted, free of charge, to any person obtaining a diff --git a/src/sherlodoc/type_distance.mli b/src/sherlodoc/type_distance.mli index 89e884bc3..d4bd0b3d8 100644 --- a/src/sherlodoc/type_distance.mli +++ b/src/sherlodoc/type_distance.mli @@ -3,7 +3,7 @@ This file is part of Merlin, an helper for ocaml editors Copyright (C) 2013 - 2024 Xavier Van de Woestyne - Arthur Wendling + Arthur Wendling Permission is hereby granted, free of charge, to any person obtaining a diff --git a/src/sherlodoc/type_expr.ml b/src/sherlodoc/type_expr.ml index 83765c2e8..b7322b163 100644 --- a/src/sherlodoc/type_expr.ml +++ b/src/sherlodoc/type_expr.ml @@ -3,7 +3,7 @@ This file is part of Merlin, an helper for ocaml editors Copyright (C) 2013 - 2024 Xavier Van de Woestyne - Arthur Wendling + Arthur Wendling Permission is hereby granted, free of charge, to any person obtaining a diff --git a/src/sherlodoc/type_expr.mli b/src/sherlodoc/type_expr.mli index 03c1af7cd..211792594 100644 --- a/src/sherlodoc/type_expr.mli +++ b/src/sherlodoc/type_expr.mli @@ -3,7 +3,7 @@ This file is part of Merlin, an helper for ocaml editors Copyright (C) 2013 - 2024 Xavier Van de Woestyne - Arthur Wendling + Arthur Wendling Permission is hereby granted, free of charge, to any person obtaining a diff --git a/src/sherlodoc/type_parsed.ml b/src/sherlodoc/type_parsed.ml index 2a99c81cd..c7166998b 100644 --- a/src/sherlodoc/type_parsed.ml +++ b/src/sherlodoc/type_parsed.ml @@ -3,7 +3,7 @@ This file is part of Merlin, an helper for ocaml editors Copyright (C) 2013 - 2024 Xavier Van de Woestyne - Arthur Wendling + Arthur Wendling Permission is hereby granted, free of charge, to any person obtaining a diff --git a/src/sherlodoc/type_parsed.mli b/src/sherlodoc/type_parsed.mli index a4f62d120..f2a36136f 100644 --- a/src/sherlodoc/type_parsed.mli +++ b/src/sherlodoc/type_parsed.mli @@ -3,7 +3,7 @@ This file is part of Merlin, an helper for ocaml editors Copyright (C) 2013 - 2024 Xavier Van de Woestyne - Arthur Wendling + Arthur Wendling Permission is hereby granted, free of charge, to any person obtaining a diff --git a/src/sherlodoc/type_polarity.ml b/src/sherlodoc/type_polarity.ml index 2be3949fc..541cbebc3 100644 --- a/src/sherlodoc/type_polarity.ml +++ b/src/sherlodoc/type_polarity.ml @@ -3,7 +3,7 @@ This file is part of Merlin, an helper for ocaml editors Copyright (C) 2013 - 2024 Xavier Van de Woestyne - Arthur Wendling + Arthur Wendling Permission is hereby granted, free of charge, to any person obtaining a diff --git a/src/sherlodoc/type_polarity.mli b/src/sherlodoc/type_polarity.mli index e77d292bf..db282dbe6 100644 --- a/src/sherlodoc/type_polarity.mli +++ b/src/sherlodoc/type_polarity.mli @@ -3,7 +3,7 @@ This file is part of Merlin, an helper for ocaml editors Copyright (C) 2013 - 2024 Xavier Van de Woestyne - Arthur Wendling + Arthur Wendling Permission is hereby granted, free of charge, to any person obtaining a diff --git a/tests/test-units/sherldoc/dune b/tests/test-units/sherldoc/dune new file mode 100644 index 000000000..f84c9d6d2 --- /dev/null +++ b/tests/test-units/sherldoc/dune @@ -0,0 +1,3 @@ +(test + (name sherlodoc_test) + (libraries fmt alcotest merlin-lib.sherlodoc)) diff --git a/tests/test-units/sherldoc/name_cost_test.ml b/tests/test-units/sherldoc/name_cost_test.ml new file mode 100644 index 000000000..8320b2b1c --- /dev/null +++ b/tests/test-units/sherldoc/name_cost_test.ml @@ -0,0 +1,126 @@ +open Merlin_sherlodoc + +let test_distance_1 = + let open Alcotest in + test_case "test distance - 1" `Quick (fun () -> + let expected = List.map Option.some [ 0; 1; 1; 1; 1; 2; 2; 2; 2 ] + and computed = + List.map + (Name_cost.distance "decode") + [ + "decode"; + "decade"; + "decede"; + "decide"; + "recode"; + "bbcode"; + "become"; + "code"; + "derobe"; + ] + in + check (list @@ option int) "should be equal" expected computed) + +let test_distance_2 = + let open Alcotest in + test_case "test distance - 2" `Quick (fun () -> + let expected = Some 1 + and computed = Name_cost.distance "Foo.Bar.Baz" "Foo_Bar.Baz" in + check (option int) "should be equal" expected computed) + +let test_distance_3 = + let open Alcotest in + test_case "test distance - 3" `Quick (fun () -> + let expected = Some 2 + and computed = Name_cost.distance "Ltw_mutex" "Lwt_mutex" in + check (option int) "should be equal" expected computed) + +let test_distance_4 = + let open Alcotest in + test_case "test distance - 4" `Quick (fun () -> + let expected = Some 4 + and computed = Name_cost.distance "Foo_Bar_Baz" "Bar_Baz" in + check (option int) "should be equal" expected computed) + +let test_distance_5 = + let open Alcotest in + test_case "test distance - 5" `Quick (fun () -> + let expected = None + and computed = + Name_cost.distance ~cutoff:16 "Ocaml_typing.Misc.f" "Bar_Baz" + in + check (option int) "should be equal" expected computed) + +let test_distance_substring_1 = + let open Alcotest in + test_case "test distance_substring - 1" `Quick (fun () -> + let expected = Some 2 + and computed = Name_cost.distance_of_substring "Foo" "Bar.Foo.Baz" in + check (option int) "should be equal" expected computed) + +let test_distance_substring_2 = + let open Alcotest in + test_case "test distance_substring - 2" `Quick (fun () -> + let expected = Some 5 + and computed = Name_cost.distance_of_substring "Foo" "Bar.oFo.Baz" in + check (option int) "should be equal" expected computed) + +let test_distance_substring_3 = + let open Alcotest in + test_case "test distance_substring - 3" `Quick (fun () -> + let expected = Some 0 + and computed = Name_cost.distance_of_substring "Foo" "Foo" in + check (option int) "should be equal" expected computed) + +let test_distance_substring_4 = + let open Alcotest in + test_case "test distance_substring - 4" `Quick (fun () -> + let expected = Some 4 + and computed = Name_cost.distance_of_substring "Foo" "Hashtblk" in + check (option int) "should be equal" expected computed) + +let test_best_distance_1 = + let open Alcotest in + test_case "test bast distance - 1" `Quick (fun () -> + let expected = 2 + and computed = + Name_cost.best_distance [ "bz"; "dddd"; "Foo" ] "Bar.Foo.Baz" + in + check int "should be equal" expected computed) + +let test_best_distance_2 = + let open Alcotest in + test_case "test bast distance - 2" `Quick (fun () -> + let expected = 4 + and computed = + Name_cost.best_distance [ "bz"; "dddd"; "oFo" ] "Bar.Foo.Baz" + in + check int "should be equal" expected computed) + +let test_best_distance_3 = + let open Alcotest in + test_case "test bast distance - 3" `Quick (fun () -> + let expected = 5 + and computed = + Name_cost.best_distance + [ "bsadsadz"; "dddd"; "moduleHassh" ] + "Bar.Foo.Baz" + in + check int "should be equal" expected computed) + +let cases = + ( "name_cost", + [ + test_distance_1; + test_distance_2; + test_distance_3; + test_distance_4; + test_distance_5; + test_distance_substring_1; + test_distance_substring_2; + test_distance_substring_3; + test_distance_substring_4; + test_best_distance_1; + test_best_distance_2; + test_best_distance_3; + ] ) diff --git a/tests/test-units/sherldoc/name_cost_test.mli b/tests/test-units/sherldoc/name_cost_test.mli new file mode 100644 index 000000000..bf105b099 --- /dev/null +++ b/tests/test-units/sherldoc/name_cost_test.mli @@ -0,0 +1 @@ +val cases : string * unit Alcotest.test_case list diff --git a/tests/test-units/sherldoc/query_parser_test.ml b/tests/test-units/sherldoc/query_parser_test.ml new file mode 100644 index 000000000..899227bc0 --- /dev/null +++ b/tests/test-units/sherldoc/query_parser_test.ml @@ -0,0 +1,126 @@ +open Merlin_sherlodoc + +let test_distance_1 = + let open Alcotest in + test_case "test distance from a query - 1" `Quick (fun () -> + let query = "List.map" + and path = "List.map" + and candidate = "('a -> 'b) -> 'a list -> 'b list" in + let expected = 0 + and computed = + Query_parser.( + distance_for (from_string query) ~path + (candidate |> Type_expr.from_string |> Option.get)) + in + check int "should be equal" expected computed) + +let test_distance_2 = + let open Alcotest in + test_case "test distance from a query - 2" `Quick (fun () -> + let query = "List.map : ('f -> 'g) -> 'f list -> 'g list" + and path = "List.map" + and candidate = "('a -> 'b) -> 'a list -> 'b list" in + let expected = 0 + and computed = + Query_parser.( + distance_for (from_string query) ~path + (candidate |> Type_expr.from_string |> Option.get)) + in + check int "should be equal" expected computed) + +let test_distance_3 = + let open Alcotest in + test_case "test distance from a query - 3" `Quick (fun () -> + let query = "('f -> 'g) -> 'f list -> 'g list" + and path = "List.map" + and candidate = "('a -> 'b) -> 'a list -> 'b list" in + let expected = 0 + and computed = + Query_parser.( + distance_for (from_string query) ~path + (candidate |> Type_expr.from_string |> Option.get)) + in + check int "should be equal" expected computed) + +let test_distance_4 = + let open Alcotest in + test_case "test distance from a query - 4" `Quick (fun () -> + let query = "map : ('f -> 'g) -> 'f list -> 'g list" + and path = "List.map" + and candidate = "('a -> 'b) -> 'a list -> 'b list" in + let expected = 1 + and computed = + Query_parser.( + distance_for (from_string query) ~path + (candidate |> Type_expr.from_string |> Option.get)) + in + check int "should be equal" expected computed) + +let test_distance_5 = + let open Alcotest in + test_case "test distance from a query - 5" `Quick (fun () -> + let query = "map : 'f list -> ('f -> 'g) -> 'g list" + and path = "List.map" + and candidate = "('a -> 'b) -> 'a list -> 'b list" in + let expected = 1 + and computed = + Query_parser.( + distance_for (from_string query) ~path + (candidate |> Type_expr.from_string |> Option.get)) + in + check int "should be equal" expected computed) + +let test_distance_6 = + let open Alcotest in + test_case "test distance from a query - 6" `Quick (fun () -> + let query = "map : 'f list * ('f -> 'g) -> 'g list" + and path = "List.map" + and candidate = "('a -> 'b) -> 'a list -> 'b list" in + let expected = 4 + and computed = + Query_parser.( + distance_for (from_string query) ~path + (candidate |> Type_expr.from_string |> Option.get)) + in + check int "should be equal" expected computed) + +let test_distance_7 = + let open Alcotest in + test_case "test distance from a query - 7" `Quick (fun () -> + let query = "List : 'f list -> ('f -> 'g) -> 'g list" + and path = "List.map" + and candidate = "('a -> 'b) -> 'a list -> 'b list" in + let expected = 1 + and computed = + Query_parser.( + distance_for (from_string query) ~path + (candidate |> Type_expr.from_string |> Option.get)) + in + check int "should be equal" expected computed) + +let test_distance_8 = + let open Alcotest in + test_case "test distance from a query - 8" `Quick (fun () -> + let query = "string -> int option" + and path = "List.map" + and candidate = "('a -> 'b) -> 'a list -> 'b list" in + let expected = 1000 + and computed = + Query_parser.( + distance_for (from_string query) ~path + (candidate |> Type_expr.from_string |> Option.get)) + in + check int "should be equal" expected computed) + +let cases = + ( "query-parser", + [ + test_distance_1; + test_distance_2; + test_distance_3; + test_distance_4; + test_distance_5; + test_distance_6; + test_distance_7; + test_distance_8; + ] ) diff --git a/tests/test-units/sherldoc/query_parser_test.mli b/tests/test-units/sherldoc/query_parser_test.mli new file mode 100644 index 000000000..bf105b099 --- /dev/null +++ b/tests/test-units/sherldoc/query_parser_test.mli @@ -0,0 +1 @@ +val cases : string * unit Alcotest.test_case list diff --git a/tests/test-units/sherldoc/sherlodoc_test.ml b/tests/test-units/sherldoc/sherlodoc_test.ml new file mode 100644 index 000000000..7882220b5 --- /dev/null +++ b/tests/test-units/sherldoc/sherlodoc_test.ml @@ -0,0 +1,8 @@ +let () = + Alcotest.run "merlin-lib.sherlodoc" + [ + Type_expr_test.cases; + Name_cost_test.cases; + Type_distance_test.cases; + Query_parser_test.cases; + ] diff --git a/tests/test-units/sherldoc/type_distance_test.ml b/tests/test-units/sherldoc/type_distance_test.ml new file mode 100644 index 000000000..b8aabd391 --- /dev/null +++ b/tests/test-units/sherldoc/type_distance_test.ml @@ -0,0 +1,45 @@ +open Merlin_sherlodoc + +let expected_distance query entry expected = + let open Alcotest in + test_case + ("distance between `" ^ query ^ "` and `" ^ entry ^ "`") + `Quick + (fun () -> + let query = query |> Type_expr.from_string |> Option.get in + let entry = entry |> Type_expr.from_string |> Option.get in + let computed = Type_distance.compute ~query ~entry in + check int + ("distance should be " ^ string_of_int expected) + expected computed) + +let cases = + ( "type_distance", + [ + expected_distance "int" "int" 0; + expected_distance "string" "string" 0; + expected_distance "string -> int" "string -> int" 0; + expected_distance "string -> int -> float" "string -> int -> float" 0; + expected_distance "int -> srting -> float" "int -> string -> float" 2; + expected_distance "('a -> 'b) -> 'a list -> 'b list" + "('a -> 'b) -> 'a list -> 'b list" 0; + expected_distance "('foo -> 'bar) -> 'foo list -> 'bar list" + "('a -> 'b) -> 'a list -> 'b list" 0; + expected_distance "'foo list -> ('foo -> 'bar) -> 'bar list" + "('a -> 'b) -> 'a list -> 'b list" 0; + expected_distance "foo -> bar -> baz" "int -> string" 1000; + expected_distance "('a -> 'b) * 'a list -> 'b list" + "('a -> 'b) -> 'a list -> 'b list" 3; + expected_distance "'a * 'b -> 'b" "'a * 'b -> 'a" 1; + expected_distance "'a * 'b -> 'a" "'a * 'b -> 'a" 0; + expected_distance + "'a -> 'b -> 'b -> 'a -> 'b -> 'c -> int -> string -> Bar.t -> 'b \ + option" + "'foo -> 'bar -> 'bar -> 'foo -> 'bar -> 'baz -> foo -> Bar.t -> int \ + -> 'bar option" + 6; + expected_distance "('a -> 'a) -> 'a list -> 'a list" + "('a -> 'b) -> 'a list -> 'b list" 2; + expected_distance "'a -> 'b option -> 'a option" + "'b option -> 'a -> 'a option" 3; + ] ) diff --git a/tests/test-units/sherldoc/type_distance_test.mli b/tests/test-units/sherldoc/type_distance_test.mli new file mode 100644 index 000000000..bf105b099 --- /dev/null +++ b/tests/test-units/sherldoc/type_distance_test.mli @@ -0,0 +1 @@ +val cases : string * unit Alcotest.test_case list diff --git a/tests/test-units/sherldoc/type_expr_test.ml b/tests/test-units/sherldoc/type_expr_test.ml new file mode 100644 index 000000000..0a5b7b18f --- /dev/null +++ b/tests/test-units/sherldoc/type_expr_test.ml @@ -0,0 +1,146 @@ +open Merlin_sherlodoc + +let type_testable = + let pp ppf x = Format.fprintf ppf "%s" (Type_expr.to_string x) in + Alcotest.testable pp Type_expr.equal + +let test_parse_simple_type_1 = + let open Alcotest in + test_case "parse a simple type expression - 1" `Quick (fun () -> + let expected = Some Type_expr.(Tycon ("int", [])) + and computed = Type_expr.from_string "int" in + check (option type_testable) "should be an integer" expected computed) + +let test_parse_simple_type_2 = + let open Alcotest in + test_case "parse a simple type expression - 2" `Quick (fun () -> + let expected = Some Type_expr.(Tycon ("Result.t", [ Tyvar 0; Tyvar 1 ])) + and computed = Type_expr.from_string "('foo, 'bar) Result.t" in + check (option type_testable) "should be a result" expected computed) + +let test_parse_simple_type_3 = + let open Alcotest in + test_case "parse a simple type expression - 3" `Quick (fun () -> + let expected = + Some + Type_expr.( + Arrow + ( Arrow (Tyvar 0, Tyvar 1), + Arrow (Tycon ("list", [ Tyvar 0 ]), Tycon ("list", [ Tyvar 1 ])) + )) + and computed = Type_expr.from_string "('a -> 'b) -> 'a list -> 'b list" in + check (option type_testable) "should be the map function" expected + computed) + +let test_parse_simple_type_4 = + let open Alcotest in + test_case "parse a simple type expression - 4" `Quick (fun () -> + let expected = Some Type_expr.(Arrow (Wildcard, Tycon ("Foo.bar", []))) + and computed = Type_expr.from_string "_ -> Foo.bar" in + check (option type_testable) "should be a simple query" expected computed) + +let test_simple_isomorphismic_poly_function_1 = + let open Alcotest in + test_case + "ensure that function equivalent function are parsed as the same function \ + - 1" + `Quick (fun () -> + let expected = Type_expr.from_string "('a -> 'b) -> 'a list -> 'b list" + and computed = + Type_expr.from_string "('foo -> 'bar) -> 'foo list -> 'bar list" + in + check (option type_testable) "should be equal" expected computed) + +let test_poly_identifier_1 = + let open Alcotest in + test_case "recompute type variables - 1" `Quick (fun () -> + let expected = + Some + "'a -> 'b -> 'a -> 'c -> 'd -> int -> ('a * 'c * string * 'b * 'c * \ + ('a, 'b) result) -> 'd t" + and computed = + "'foo -> 'bar -> 'foo -> 'baz -> 'rk -> int -> 'foo * 'baz * string * \ + 'bar * 'baz * ('foo, 'bar) result -> 'rk t" |> Type_expr.from_string + |> Option.map Type_expr.to_string + in + check (option string) "should be equal" expected computed) + +let test_long_poly_identifier_1 = + let open Alcotest in + test_case "check polymorphic variable identifier generation - 1" `Quick + (fun () -> + let expected = + Some + "'a -> 'b -> 'c -> 'b -> 'c -> 'c -> 'b -> 'd -> 'e -> 'f -> 'g -> \ + 'h -> 'i -> 'j -> int -> float -> 'k -> 'l -> 'm -> 'n -> 'o -> 'p \ + -> 'q -> 'r option -> 'b -> 's -> 't -> 'u -> 'a Option.t -> ('b, \ + 'c) Result.t -> 'a -> 'r -> 'v -> 'd -> 'e -> 'w -> 'f -> 'g -> 'x \ + -> 'y -> 'z -> 'aa -> 'bb -> 'cc -> 'dd -> 'ee -> 'ff -> 'gg -> 'hh \ + -> 'ii -> 'jj -> 'kk -> 'll -> 'mm -> 'nn -> 'oo -> 'pp -> 'qq -> \ + 'rr -> 'ss -> 'tt -> 'uu -> 'vv -> 'ww -> 'xx -> 'yy -> 'zz -> 'aaa \ + -> 'bbb -> 'ccc -> 'ddd -> 'eee -> 'fff -> 'ggg -> 'hhh -> 'k -> \ + 'iii -> 'jjj -> 'kkk -> 'lll -> 'mmm -> 'nnn -> 'ooo -> 'ppp -> \ + 'qqq -> 'rrr -> 'n -> 'sss -> 'ttt -> 'uuu -> 'vvv -> 'www -> 'o -> \ + 'xxx -> 'yyy -> 'zzz -> 'aaaa -> 'bbbb -> 'cccc -> 'dddd -> 'eeee \ + -> 'l -> 'ffff -> 'gggg -> 'hhhh -> 'iiii -> 'jjjj -> 'kkkk -> \ + 'llll -> 'mmmm -> 'nnnn -> 'oooo -> 'pppp -> 'p -> 'qqqq -> 'rrrr \ + -> 'ssss -> 'tttt -> 'uuuu -> 'vvvv -> 'wwww -> 'xxxx -> 'yyyy -> \ + 'zzzz -> 'aaaaa -> 'bbbbb -> 'ccccc -> 'm -> 'ddddd -> 'eeeee -> \ + 'fffff -> 'ggggg -> 'hhhhh -> 'iiiii -> 'jjjjj -> 'kkkkk -> 'lllll \ + -> 'mmmmm -> 'nnnnn -> 'ooooo -> 'ppppp -> 'qqqqq -> 'rrrrr -> \ + 'sssss -> 'ttttt -> 'uuuuu -> 'vvvvv -> 'wwwww -> 'xxxxx -> 'yyyyy \ + -> 'zzzzz -> 'aaaaaa -> 'bbbbbb -> 'cccccc -> 'dddddd -> 'eeeeee -> \ + 'ffffff -> 'gggggg -> 'hhhhhh -> 'iiiiii -> 'jjjjjj -> 'kkkkkk -> \ + 'llllll -> 'mmmmmm -> 'nnnnnn -> 'oooooo -> 'pppppp -> 'qqqqqq -> \ + 'rrrrrr -> 'ssssss -> 'tttttt -> 'uuuuuu -> 'vvvvvv -> 'wwwwww -> \ + 'xxxxxx -> 'yyyyyy -> 'zzzzzz -> 'aaaaaaa -> 'bbbbbbb -> 'ccccccc \ + -> 'ddddddd -> 'eeeeeee -> 'fffffff -> 'ggggggg -> 'hhhhhhh -> \ + 'iiiiiii -> 'jjjjjjj -> 'kkkkkkk -> 'lllllll -> 'mmmmmmm -> \ + 'nnnnnnn -> 'ooooooo -> 'ppppppp -> 'qqqqqqq -> 'rrrrrrr -> \ + 'sssssss -> 'ttttttt -> 'uuuuuuu -> 'vvvvvvv -> 'wwwwwww -> \ + 'xxxxxxx -> 'yyyyyyy -> 'zzzzzzz -> 'aaaaaaaa -> 'bbbbbbbb -> \ + 'cccccccc -> 'dddddddd -> 'eeeeeeee -> 'ffffffff -> 'gggggggg -> 'g" + and computed = + "'a -> 'foo -> 'bar -> 'foo -> 'bar -> 'bar -> 'foo -> 'd -> 'e -> 'g \ + -> 'h -> 't1 -> 't3 -> 't4 -> int -> float -> 'tt -> 'ttt -> 'tttt -> \ + 'eee -> 'kkk -> 'ffff -> 'aq -> 'b option -> 'foo -> 'aaaaaaaa -> 'f2 \ + -> 'f3 -> 'a Option.t -> ('foo, 'bar) Result.t -> 'a -> 'b -> 'c -> \ + 'd -> 'e -> 'f -> 'g -> 'h -> 'i -> 'j -> 'k -> 'l -> 'm -> 'n -> 'o \ + -> 'p -> 'q -> 'r -> 's -> 't -> 'u -> 'v -> 'w -> 'x -> 'y -> 'z -> \ + 'aa -> 'bb -> 'cc -> 'dd -> 'ee -> 'ff -> 'gg -> 'hh -> 'ii -> 'jj -> \ + 'kk -> 'll -> 'mm -> 'nn -> 'oo -> 'pp -> 'qq -> 'rr -> 'ss -> 'tt -> \ + 'uu -> 'vv -> 'ww -> 'xx -> 'yy -> 'zz -> 'aaa -> 'bbb -> 'ccc -> \ + 'ddd -> 'eee -> 'fff -> 'ggg -> 'hhh -> 'iii -> 'jjj -> 'kkk -> 'lll \ + -> 'mmm -> 'nnn -> 'ooo -> 'ppp -> 'qqq -> 'rrr -> 'sss -> 'ttt -> \ + 'uuu -> 'vvv -> 'www -> 'xxx -> 'yyy -> 'zzz -> 'aaaa -> 'bbbb -> \ + 'cccc -> 'dddd -> 'eeee -> 'ffff -> 'gggg -> 'hhhh -> 'iiii -> 'jjjj \ + -> 'kkkk -> 'llll -> 'mmmm -> 'nnnn -> 'oooo -> 'pppp -> 'qqqq -> \ + 'rrrr -> 'ssss -> 'tttt -> 'uuuu -> 'vvvv -> 'wwww -> 'xxxx -> 'yyyy \ + -> 'zzzz -> 'aaaaa -> 'bbbbb -> 'ccccc -> 'ddddd -> 'eeeee -> 'fffff \ + -> 'ggggg -> 'hhhhh -> 'iiiii -> 'jjjjj -> 'kkkkk -> 'lllll -> 'mmmmm \ + -> 'nnnnn -> 'ooooo -> 'ppppp -> 'qqqqq -> 'rrrrr -> 'sssss -> 'ttttt \ + -> 'uuuuu -> 'vvvvv -> 'wwwww -> 'xxxxx -> 'yyyyy -> 'zzzzz -> \ + 'aaaaaa -> 'bbbbbb -> 'cccccc -> 'dddddd -> 'eeeeee -> 'ffffff -> \ + 'gggggg -> 'hhhhhh -> 'iiiiii -> 'jjjjjj -> 'kkkkkk -> 'llllll -> \ + 'mmmmmm -> 'nnnnnn -> 'oooooo -> 'pppppp -> 'qqqqqq -> 'rrrrrr -> \ + 'ssssss -> 'tttttt -> 'uuuuuu -> 'vvvvvv -> 'wwwwww -> 'xxxxxx -> \ + 'yyyyyy -> 'zzzzzz -> 'aaaaaaa -> 'bbbbbbb -> 'ccccccc -> 'ddddddd -> \ + 'eeeeeee -> 'fffffff -> 'ggggggg -> 'hhhhhhh -> 'iiiiiii -> 'jjjjjjj \ + -> 'kkkkkkk -> 'lllllll -> 'mmmmmmm -> 'nnnnnnn -> 'ooooooo -> \ + 'ppppppp -> 'qqqqqqq -> 'rrrrrrr -> 'sssssss -> 'ttttttt -> 'uuuuuuu \ + -> 'vvvvvvv -> 'wwwwwww -> 'xxxxxxx -> 'h" |> Type_expr.from_string + |> Option.map Type_expr.to_string + in + check (option string) "should be equal" expected computed) + +let cases = + ( "type_expr", + [ + test_parse_simple_type_1; + test_parse_simple_type_2; + test_parse_simple_type_3; + test_parse_simple_type_4; + test_simple_isomorphismic_poly_function_1; + test_poly_identifier_1; + test_long_poly_identifier_1; + ] ) diff --git a/tests/test-units/sherldoc/type_expr_test.mli b/tests/test-units/sherldoc/type_expr_test.mli new file mode 100644 index 000000000..bf105b099 --- /dev/null +++ b/tests/test-units/sherldoc/type_expr_test.mli @@ -0,0 +1 @@ +val cases : string * unit Alcotest.test_case list From efedbdc7c4dc2b5e766bf70675b3810a153256f8 Mon Sep 17 00:00:00 2001 From: xvw Date: Mon, 9 Sep 2024 18:42:16 +0200 Subject: [PATCH 04/24] Add search-by-type in merlin protocol --- src/analysis/type_search.ml | 104 ++++++++ src/analysis/type_search.mli | 45 ++++ src/commands/new_commands.ml | 28 +++ src/commands/query_json.ml | 17 ++ src/frontend/dune | 1 + src/frontend/query_commands.ml | 22 ++ src/frontend/query_protocol.ml | 4 + src/sherlodoc/type_distance.ml | 1 + src/sherlodoc/type_expr.mli | 4 + src/utils/marg.ml | 6 + src/utils/marg.mli | 3 + tests/test-dirs/search-by-type.t/context.ml | 1 + tests/test-dirs/search-by-type.t/run.t | 260 ++++++++++++++++++++ 13 files changed, 496 insertions(+) create mode 100644 src/analysis/type_search.ml create mode 100644 src/analysis/type_search.mli create mode 100644 tests/test-dirs/search-by-type.t/context.ml create mode 100644 tests/test-dirs/search-by-type.t/run.t diff --git a/src/analysis/type_search.ml b/src/analysis/type_search.ml new file mode 100644 index 000000000..d93f9c225 --- /dev/null +++ b/src/analysis/type_search.ml @@ -0,0 +1,104 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2024 Frédéric Bour + Thomas Refis + Simon Castellan + Arthur Wendling + Xavier Van de Woestyne + + 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 + +type trie = + | T of string * Longident.t * t Lazy.t +and t = trie list + +let type_of 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 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_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 run ?(limit = 100) env query trie = + let fold_values dir acc = + Env.fold_values (fun _ path desc acc -> + let open Merlin_sherlodoc in + let typ = type_of desc.Types.val_type 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 (cost, path, desc) :: 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 + in + match force () with + | computed_children -> + let init = fold_values (Some dir) acc in + List.fold_left ~init ~f:walk computed_children + | exception _ -> acc + in + let init = fold_values None [] in + trie + |> List.fold_left ~init ~f:walk + |> List.sort ~cmp:(fun (cost_a, a, _) (cost_b, b, _) -> + let c = Int.compare cost_a cost_b in + if Int.equal c 0 then + Int.compare (String.length a) (String.length b) + else c + ) + |> List.take_n limit + + diff --git a/src/analysis/type_search.mli b/src/analysis/type_search.mli new file mode 100644 index 000000000..1aef28674 --- /dev/null +++ b/src/analysis/type_search.mli @@ -0,0 +1,45 @@ +(* {{{ COPYING *( + + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2024 Frédéric Bour + Thomas Refis + Simon Castellan + Arthur Wendling + Xavier Van de Woestyne + + 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. + + )* }}} *) + +(** Search by type in the current environment. *) + +(** A Lazy trie of the potentials values. *) +type t + +(** Initiailzie 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 -> + Env.t -> + Merlin_sherlodoc.Query_parser.t + -> t + -> (int * string * Types.value_description) list diff --git a/src/commands/new_commands.ml b/src/commands/new_commands.ml index 02d23b99a..836c3334f 100644 --- a/src/commands/new_commands.ml +++ b/src/commands/new_commands.ml @@ -580,6 +580,34 @@ let all_commands = | #Msource.position as pos -> run buffer (Query_protocol.Polarity_search (query, pos)) end; + command "search-by-type" ~doc:"return a list of values that match a query" + ~spec: + [ arg "-position" " to complete" + (marg_position (fun pos (query, _pos, limit, with_doc) -> + (query, pos, limit, with_doc))); + arg "-query" " to request values" + (Marg.param "string" (fun query (_query, pos, limit, with_doc) -> + (Some query, pos, limit, with_doc))); + optional "-limit" + " the maximal amount of results (default is 100)" + (Marg.int (fun limit (query, pos, _limit, with_doc) -> + (query, pos, limit, with_doc))); + optional "-with-doc" " include docstring (default is false)" + (Marg.bool (fun with_doc (query, pos, limit, _with_doc) -> + (query, pos, limit, with_doc))) + ] + ~default:(None, `None, 100, false) + begin + fun buffer (query, pos, limit, with_doc) -> + match (query, pos) with + | None, `None -> + failwith "-position and -query are mandatory" + | None, _ -> failwith "-query is mandatory" + | _, `None -> failwith "-position is mandatory" + | Some query, (#Msource.position as pos) -> + run buffer + (Query_protocol.Type_search (query, pos, limit, with_doc)) + end; command "inlay-hints" ~doc:"return a list of inly-hints for additional client (like LSP)" ~spec: diff --git a/src/commands/query_json.ml b/src/commands/query_json.ml index de1b60831..840cf56bd 100644 --- a/src/commands/query_json.ml +++ b/src/commands/query_json.ml @@ -178,6 +178,12 @@ let dump (type a) : a t -> json = | Polarity_search (query, pos) -> mk "polarity-search" [ ("query", `String query); ("position", mk_position pos) ] + | Type_search (query, pos, limit) -> + mk "type-search" + [ ("query", `String query); + ("position", mk_position pos); + ("limit", `Int limit) + ] | Occurrences (`Ident_at pos, scope) -> mk "occurrences" [ ("kind", `String "identifiers"); @@ -372,6 +378,16 @@ let json_of_signature_help resp = ("activeSignature", `Int active_signature) ] +let json_of_search_result list = + let list = + List.map + ~f:(fun { name; typ; loc; cost } -> + with_location ~with_file:true loc + [ ("name", `String name); ("type", `String typ); ("cost", `Int cost) ]) + list + in + `List list + let json_of_response (type a) (query : a t) (response : a) : json = match (query, response) with | Type_expr _, str -> `String str @@ -381,6 +397,7 @@ let json_of_response (type a) (query : a t) (response : a) : json = | Complete_prefix _, compl -> json_of_completions compl | Expand_prefix _, compl -> json_of_completions compl | Polarity_search _, compl -> json_of_completions compl + | Type_search _, result -> json_of_search_result result | Refactor_open _, locations -> `List (List.map locations ~f:(fun (name, loc) -> diff --git a/src/frontend/dune b/src/frontend/dune index c5597f13f..f04d9329d 100644 --- a/src/frontend/dune +++ b/src/frontend/dune @@ -29,5 +29,6 @@ merlin_specific merlin_config merlin_analysis + merlin_sherlodoc query_protocol str)) diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index 0ffe4b0d1..f4f93ace8 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -476,6 +476,28 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function { Compl.name; kind = `Value; desc; info = ""; deprecated = false }) in { 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 pos = Mpipeline.get_lexing_pos pipeline pos in + let node = Mtyper.node_at typer pos in + let env, _ = Mbrowse.leaf_node node in + let config = Mpipeline.final_config pipeline in + let modules = Mconfig.global_modules config in + let trie = Type_search.make_trie env modules in + let result = Type_search.run ~limit env query trie in + let verbosity = verbosity pipeline in + Printtyp.wrap_printing_env ~verbosity env (fun () -> + List.map + ~f:(fun (cost, name, typ) -> + 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 }) + result) | Refactor_open (mode, pos) -> let typer = Mpipeline.typer_result pipeline in let pos = Mpipeline.get_lexing_pos pipeline pos in diff --git a/src/frontend/query_protocol.ml b/src/frontend/query_protocol.ml index 911465d9e..68dedf10d 100644 --- a/src/frontend/query_protocol.ml +++ b/src/frontend/query_protocol.ml @@ -67,6 +67,9 @@ end type completions = Compl.t +type type_search_result = + { name : string; typ : string; loc : Location_aux.t; cost : int } + type outline = item list and item = { outline_name : string; @@ -139,6 +142,7 @@ type _ t = string * Msource.position * Compl.kind list * [ `with_types ] _bool -> completions t | Polarity_search : string * Msource.position -> completions t + | Type_search : string * Msource.position * int -> type_search_result list t | Refactor_open : [ `Qualify | `Unqualify ] * Msource.position -> (string * Location.t) list t diff --git a/src/sherlodoc/type_distance.ml b/src/sherlodoc/type_distance.ml index 435ab6b8e..60dbda453 100644 --- a/src/sherlodoc/type_distance.ml +++ b/src/sherlodoc/type_distance.ml @@ -49,6 +49,7 @@ let make_path t = | Type_expr.Tycon (constr, []) -> [ Tyname constr :: prefix ] | Type_expr.Tycon (constr, args) -> let length = String.length constr in + let prefix = Tyname constr :: prefix in args |> List.mapi (fun position arg -> let prefix = Argument { position; length } :: prefix in diff --git a/src/sherlodoc/type_expr.mli b/src/sherlodoc/type_expr.mli index 211792594..67f6e0bcf 100644 --- a/src/sherlodoc/type_expr.mli +++ b/src/sherlodoc/type_expr.mli @@ -43,6 +43,10 @@ type t = | Wildcard | Unhandled +val normalize_type_parameters : Type_parsed.t -> t +(** [normalize_type_parameters ty] replace string based type variables to + integer based type variables. *) + val from_string : string -> t option (** Try deserializing a string into a typed expression. *) diff --git a/src/utils/marg.ml b/src/utils/marg.ml index 58ab0ad39..7046cf96a 100644 --- a/src/utils/marg.ml +++ b/src/utils/marg.ml @@ -26,6 +26,12 @@ let bool f = failwithf "expecting boolean (%s), got %S." "yes|y|Y|true|1 / no|n|N|false|0" str) +let int f = param "int" (fun str -> + match int_of_string_opt str with + | None -> failwithf "expecting integer got %S." str + | Some x -> f x + ) + type docstring = string type 'a spec = string * docstring * 'a t diff --git a/src/utils/marg.mli b/src/utils/marg.mli index f86719969..1aba9a1ac 100644 --- a/src/utils/marg.mli +++ b/src/utils/marg.mli @@ -25,6 +25,9 @@ val param : string -> (string -> 'acc -> 'acc) -> 'acc t (** Action consuming a boolean argument *) val bool : (bool -> 'acc -> 'acc) -> 'acc t +(** Action consuming an integer argument *) +val int : (int -> 'acc -> 'acc) -> 'acc t + (** Action doing nothing *) val unit_ignore : 'acc t diff --git a/tests/test-dirs/search-by-type.t/context.ml b/tests/test-dirs/search-by-type.t/context.ml new file mode 100644 index 000000000..306831a00 --- /dev/null +++ b/tests/test-dirs/search-by-type.t/context.ml @@ -0,0 +1 @@ +let () = () diff --git a/tests/test-dirs/search-by-type.t/run.t b/tests/test-dirs/search-by-type.t/run.t new file mode 100644 index 000000000..d218f7059 --- /dev/null +++ b/tests/test-dirs/search-by-type.t/run.t @@ -0,0 +1,260 @@ + $ $MERLIN single search-by-type -filename ./context.ml \ + > -position 5:25 -limit 10 -query "string -> int option" | + > jq '.value[] | {name,type,cost}' + { + "name": "int_of_string_opt", + "type": "string -> int option", + "cost": 0 + } + { + "name": "int_of_string_opt", + "type": "string -> int option", + "cost": 0 + } + { + "name": "Stdlib__Int32.of_string_opt", + "type": "string -> int32 option", + "cost": 2 + } + { + "name": "Stdlib__Int64.of_string_opt", + "type": "string -> int64 option", + "cost": 2 + } + { + "name": "bool_of_string_opt", + "type": "string -> bool option", + "cost": 4 + } + { + "name": "bool_of_string_opt", + "type": "string -> bool option", + "cost": 4 + } + { + "name": "float_of_string_opt", + "type": "string -> float option", + "cost": 4 + } + { + "name": "float_of_string_opt", + "type": "string -> float option", + "cost": 4 + } + { + "name": "Stdlib__Sys.getenv_opt", + "type": "string -> string option", + "cost": 4 + } + { + "name": "Stdlib__Float.of_string_opt", + "type": "string -> float option", + "cost": 4 + } + + + $ $MERLIN single search-by-type -filename ./context.ml \ + > -position 5:25 -limit 10 -query "('a -> 'b) -> 'a list -> 'b list" | + > jq '.value[] | {name,type,cost}' + { + "name": "Stdlib__List.map", + "type": "('a -> 'b) -> 'a list -> 'b list", + "cost": 0 + } + { + "name": "Stdlib__List.rev_map", + "type": "('a -> 'b) -> 'a list -> 'b list", + "cost": 0 + } + { + "name": "Stdlib__ListLabels.map", + "type": "f:('a -> 'b) -> 'a list -> 'b list", + "cost": 0 + } + { + "name": "Stdlib__ListLabels.rev_map", + "type": "f:('a -> 'b) -> 'a list -> 'b list", + "cost": 0 + } + { + "name": "Stdlib__List.mapi", + "type": "(int -> 'a -> 'b) -> 'a list -> 'b list", + "cost": 5 + } + { + "name": "Stdlib__ListLabels.mapi", + "type": "f:(int -> 'a -> 'b) -> 'a list -> 'b list", + "cost": 5 + } + { + "name": "Stdlib__List.filter_map", + "type": "('a -> 'b option) -> 'a list -> 'b list", + "cost": 10 + } + { + "name": "Stdlib__List.concat_map", + "type": "('a -> 'b list) -> 'a list -> 'b list", + "cost": 10 + } + { + "name": "Stdlib__ListLabels.filter_map", + "type": "f:('a -> 'b option) -> 'a list -> 'b list", + "cost": 10 + } + { + "name": "Stdlib__ListLabels.concat_map", + "type": "f:('a -> 'b list) -> 'a list -> 'b list", + "cost": 10 + } + + $ $MERLIN single search-by-type -filename ./context.ml \ + > -position 5:25 -limit 10 \ + > -query "Hashtbl : ('f, 'g) Hashtbl.t -> 'f -> 'g -> unit" + { + "class": "return", + "value": [ + { + "file": "hashtbl.mli", + "start": { + "line": 116, + "col": 0 + }, + "end": { + "line": 116, + "col": 40 + }, + "name": "Stdlib__Hashtbl.add", + "type": "('a, 'b) Stdlib__Hashtbl.t -> 'a -> 'b -> unit", + "cost": 35 + }, + { + "file": "hashtbl.mli", + "start": { + "line": 151, + "col": 0 + }, + "end": { + "line": 151, + "col": 44 + }, + "name": "Stdlib__Hashtbl.replace", + "type": "('a, 'b) Stdlib__Hashtbl.t -> 'a -> 'b -> unit", + "cost": 36 + }, + { + "file": "hashtbl.mli", + "start": { + "line": 301, + "col": 0 + }, + "end": { + "line": 301, + "col": 50 + }, + "name": "Stdlib__Hashtbl.add_seq", + "type": "('a, 'b) Stdlib__Hashtbl.t -> ('a * 'b) Seq.t -> unit", + "cost": 48 + }, + { + "file": "hashtbl.mli", + "start": { + "line": 305, + "col": 0 + }, + "end": { + "line": 305, + "col": 54 + }, + "name": "Stdlib__Hashtbl.replace_seq", + "type": "('a, 'b) Stdlib__Hashtbl.t -> ('a * 'b) Seq.t -> unit", + "cost": 49 + }, + { + "file": "moreLabels.mli", + "start": { + "line": 318, + "col": 2 + }, + "end": { + "line": 318, + "col": 52 + }, + "name": "Stdlib__MoreLabels.Hashtbl.add_seq", + "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> ('a * 'b) Seq.t -> unit", + "cost": 50 + }, + { + "file": "moreLabels.mli", + "start": { + "line": 322, + "col": 2 + }, + "end": { + "line": 322, + "col": 56 + }, + "name": "Stdlib__MoreLabels.Hashtbl.replace_seq", + "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> ('a * 'b) Seq.t -> unit", + "cost": 51 + }, + { + "file": "result.mli", + "start": { + "line": 47, + "col": 0 + }, + "end": { + "line": 47, + "col": 72 + }, + "name": "Stdlib__Result.bind", + "type": "('a, 'e) result -> ('a -> ('b, 'e) result) -> ('b, 'e) result", + "cost": 63 + }, + { + "file": "stdlib.mli", + "start": { + "line": 1324, + "col": 0 + }, + "end": { + "line": 1324, + "col": 65 + }, + "name": "string_of_format", + "type": "('a, 'b, 'c, 'd, 'e, 'f) format6 -> string", + "cost": 68 + }, + { + "file": "stdlib.mli", + "start": { + "line": 1324, + "col": 0 + }, + "end": { + "line": 1324, + "col": 65 + }, + "name": "string_of_format", + "type": "('a, 'b, 'c, 'd, 'e, 'f) format6 -> string", + "cost": 68 + }, + { + "file": "either.mli", + "start": { + "line": 86, + "col": 0 + }, + "end": { + "line": 87, + "col": 73 + }, + "name": "Stdlib__Either.map", + "type": "left:('a1 -> 'a2) -> + right:('b1 -> 'b2) -> + ('a1, 'b1) Stdlib__Either.t -> ('a2, 'b2) Stdlib__Either.t", + "cost": 79 + } + ], + "notifications": [] + } From eca1d818d02ff22ac9299d030b5a089e8dec8a59 Mon Sep 17 00:00:00 2001 From: xvw Date: Fri, 13 Sep 2024 13:42:41 +0200 Subject: [PATCH 05/24] Include docstring in search result --- src/analysis/type_search.ml | 30 +++++- src/analysis/type_search.mli | 6 +- src/commands/query_json.ml | 11 ++- src/frontend/query_commands.ml | 10 +- src/frontend/query_protocol.ml | 7 +- tests/test-dirs/search-by-type.t/run.t | 124 +++++++++++++++++-------- 6 files changed, 139 insertions(+), 49 deletions(-) diff --git a/src/analysis/type_search.ml b/src/analysis/type_search.ml index d93f9c225..bc41d9da6 100644 --- a/src/analysis/type_search.ml +++ b/src/analysis/type_search.ml @@ -68,7 +68,12 @@ let make_trie env modules = ) modules -let run ?(limit = 100) env query trie = +let doc_to_option = function + | `Builtin doc + | `Found doc -> Some doc + | _ -> None + +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 @@ -76,7 +81,18 @@ let run ?(limit = 100) env query trie = 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 (cost, path, desc) :: acc + else + let doc = + Locate.get_doc + ~config + ~env + ~local_defs + ~comments + ~pos + (`User_input path) + |> doc_to_option + in + (cost, path, desc, doc) :: acc ) dir env acc in let rec walk acc (T (_, dir, children)) = @@ -93,10 +109,16 @@ let run ?(limit = 100) env query trie = let init = fold_values None [] in trie |> List.fold_left ~init ~f:walk - |> List.sort ~cmp:(fun (cost_a, a, _) (cost_b, b, _) -> + |> 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 - Int.compare (String.length a) (String.length b) + 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.take_n limit diff --git a/src/analysis/type_search.mli b/src/analysis/type_search.mli index 1aef28674..16b5f7d3b 100644 --- a/src/analysis/type_search.mli +++ b/src/analysis/type_search.mli @@ -39,7 +39,11 @@ val make_trie : Env.t -> string list -> t (** 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 -> t - -> (int * string * Types.value_description) list + -> (int * string * Types.value_description * string option) list diff --git a/src/commands/query_json.ml b/src/commands/query_json.ml index 840cf56bd..5280907ce 100644 --- a/src/commands/query_json.ml +++ b/src/commands/query_json.ml @@ -381,9 +381,16 @@ let json_of_signature_help resp = let json_of_search_result list = let list = List.map - ~f:(fun { name; typ; loc; cost } -> + ~f:(fun { name; typ; loc; cost; doc } -> with_location ~with_file:true loc - [ ("name", `String name); ("type", `String typ); ("cost", `Int cost) ]) + [ ("name", `String name); + ("type", `String typ); + ("cost", `Int cost); + ( "doc", + match doc with + | Some x -> `String x + | None -> `Null ) + ]) list in `List list diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index f4f93ace8..012a89c83 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -479,24 +479,28 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function | 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 let node = Mtyper.node_at typer pos in let env, _ = Mbrowse.leaf_node node in 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 env query trie in + let result = + Type_search.run ~limit config local_defs comments pos env query trie + in let verbosity = verbosity pipeline in Printtyp.wrap_printing_env ~verbosity env (fun () -> List.map - ~f:(fun (cost, name, typ) -> + ~f:(fun (cost, name, typ, doc) -> 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 }) + { name; typ; cost; loc; doc }) result) | Refactor_open (mode, pos) -> let typer = Mpipeline.typer_result pipeline in diff --git a/src/frontend/query_protocol.ml b/src/frontend/query_protocol.ml index 68dedf10d..8941860d8 100644 --- a/src/frontend/query_protocol.ml +++ b/src/frontend/query_protocol.ml @@ -68,7 +68,12 @@ end type completions = Compl.t type type_search_result = - { name : string; typ : string; loc : Location_aux.t; cost : int } + { name : string; + typ : string; + loc : Location_aux.t; + doc : string option; + cost : int + } type outline = item list and item = diff --git a/tests/test-dirs/search-by-type.t/run.t b/tests/test-dirs/search-by-type.t/run.t index d218f7059..2e282951f 100644 --- a/tests/test-dirs/search-by-type.t/run.t +++ b/tests/test-dirs/search-by-type.t/run.t @@ -1,110 +1,130 @@ $ $MERLIN single search-by-type -filename ./context.ml \ > -position 5:25 -limit 10 -query "string -> int option" | - > jq '.value[] | {name,type,cost}' + > tr '\n' ' ' | jq '.value[] | {name,type,cost,doc}' { "name": "int_of_string_opt", "type": "string -> int option", - "cost": 0 + "cost": 0, + "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": "int_of_string_opt", "type": "string -> int option", - "cost": 0 + "cost": 0, + "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": "Stdlib__Int32.of_string_opt", "type": "string -> int32 option", - "cost": 2 + "cost": 2, + "doc": "Same as [of_string], but return [None] instead of raising. @since 4.05" } { "name": "Stdlib__Int64.of_string_opt", "type": "string -> int64 option", - "cost": 2 + "cost": 2, + "doc": "Same as [of_string], but return [None] instead of raising. @since 4.05" } { "name": "bool_of_string_opt", "type": "string -> bool option", - "cost": 4 + "cost": 4, + "doc": "Convert the given string to a boolean. Return [None] if the string is not [\"true\"] or [\"false\"]. @since 4.05" } { "name": "bool_of_string_opt", "type": "string -> bool option", - "cost": 4 + "cost": 4, + "doc": "Convert the given string to a boolean. Return [None] if the string is not [\"true\"] or [\"false\"]. @since 4.05" } { "name": "float_of_string_opt", "type": "string -> float option", - "cost": 4 + "cost": 4, + "doc": "Convert the given string to a float. The string is read in decimal (by default) or in hexadecimal (marked by [0x] or [0X]). The format of decimal floating-point numbers is [ [-] dd.ddd (e|E) [+|-] dd ], where [d] stands for a decimal digit. The format of hexadecimal floating-point numbers is [ [-] 0(x|X) hh.hhh (p|P) [+|-] dd ], where [h] stands for an hexadecimal digit and [d] for a decimal digit. In both cases, at least one of the integer and fractional parts must be given; the exponent part is optional. The [_] (underscore) character can appear anywhere in the string and is ignored. Depending on the execution platforms, other representations of floating-point numbers can be accepted, but should not be relied upon. Return [None] if the given string is not a valid representation of a float. @since 4.05" } { "name": "float_of_string_opt", "type": "string -> float option", - "cost": 4 + "cost": 4, + "doc": "Convert the given string to a float. The string is read in decimal (by default) or in hexadecimal (marked by [0x] or [0X]). The format of decimal floating-point numbers is [ [-] dd.ddd (e|E) [+|-] dd ], where [d] stands for a decimal digit. The format of hexadecimal floating-point numbers is [ [-] 0(x|X) hh.hhh (p|P) [+|-] dd ], where [h] stands for an hexadecimal digit and [d] for a decimal digit. In both cases, at least one of the integer and fractional parts must be given; the exponent part is optional. The [_] (underscore) character can appear anywhere in the string and is ignored. Depending on the execution platforms, other representations of floating-point numbers can be accepted, but should not be relied upon. Return [None] if the given string is not a valid representation of a float. @since 4.05" } { "name": "Stdlib__Sys.getenv_opt", "type": "string -> string option", - "cost": 4 + "cost": 4, + "doc": "Return the value associated to a variable in the process environment or [None] if the variable is unbound. @since 4.05" } { "name": "Stdlib__Float.of_string_opt", "type": "string -> float option", - "cost": 4 + "cost": 4, + "doc": "Same as [of_string], but returns [None] instead of raising." } $ $MERLIN single search-by-type -filename ./context.ml \ > -position 5:25 -limit 10 -query "('a -> 'b) -> 'a list -> 'b list" | - > jq '.value[] | {name,type,cost}' + > tr '\n' ' ' | jq '.value[] | {name,type,cost,doc}' { "name": "Stdlib__List.map", "type": "('a -> 'b) -> 'a list -> 'b list", - "cost": 0 + "cost": 0, + "doc": "[map f [a1; ...; an]] applies function [f] to [a1, ..., an], and builds the list [[f a1; ...; f an]] with the results returned by [f]." } { "name": "Stdlib__List.rev_map", "type": "('a -> 'b) -> 'a list -> 'b list", - "cost": 0 + "cost": 0, + "doc": "[rev_map f l] gives the same result as {!rev}[ (]{!map}[ f l)], but is more efficient." } { "name": "Stdlib__ListLabels.map", "type": "f:('a -> 'b) -> 'a list -> 'b list", - "cost": 0 + "cost": 0, + "doc": "[map ~f [a1; ...; an]] applies function [f] to [a1, ..., an], and builds the list [[f a1; ...; f an]] with the results returned by [f]." } { "name": "Stdlib__ListLabels.rev_map", "type": "f:('a -> 'b) -> 'a list -> 'b list", - "cost": 0 + "cost": 0, + "doc": "[rev_map ~f l] gives the same result as {!rev}[ (]{!map}[ f l)], but is more efficient." } { "name": "Stdlib__List.mapi", "type": "(int -> 'a -> 'b) -> 'a list -> 'b list", - "cost": 5 + "cost": 5, + "doc": "Same as {!map}, but the function is applied to the index of the element as first argument (counting from 0), and the element itself as second argument. @since 4.00" } { "name": "Stdlib__ListLabels.mapi", "type": "f:(int -> 'a -> 'b) -> 'a list -> 'b list", - "cost": 5 - } - { - "name": "Stdlib__List.filter_map", - "type": "('a -> 'b option) -> 'a list -> 'b list", - "cost": 10 + "cost": 5, + "doc": "Same as {!map}, but the function is applied to the index of the element as first argument (counting from 0), and the element itself as second argument. @since 4.00" } { "name": "Stdlib__List.concat_map", "type": "('a -> 'b list) -> 'a list -> 'b list", - "cost": 10 + "cost": 10, + "doc": "[concat_map f l] gives the same result as {!concat}[ (]{!map}[ f l)]. Tail-recursive. @since 4.10" } { - "name": "Stdlib__ListLabels.filter_map", - "type": "f:('a -> 'b option) -> 'a list -> 'b list", - "cost": 10 + "name": "Stdlib__List.filter_map", + "type": "('a -> 'b option) -> 'a list -> 'b list", + "cost": 10, + "doc": "[filter_map f l] applies [f] to every element of [l], filters out the [None] elements and returns the list of the arguments of the [Some] elements. @since 4.08" } { "name": "Stdlib__ListLabels.concat_map", "type": "f:('a -> 'b list) -> 'a list -> 'b list", - "cost": 10 + "cost": 10, + "doc": "[concat_map ~f l] gives the same result as {!concat}[ (]{!map}[ f l)]. Tail-recursive. @since 4.10" + } + { + "name": "Stdlib__ListLabels.filter_map", + "type": "f:('a -> 'b option) -> 'a list -> 'b list", + "cost": 10, + "doc": "[filter_map ~f l] applies [f] to every element of [l], filters out the [None] elements and returns the list of the arguments of the [Some] elements. @since 4.08" } $ $MERLIN single search-by-type -filename ./context.ml \ @@ -125,7 +145,17 @@ }, "name": "Stdlib__Hashtbl.add", "type": "('a, 'b) Stdlib__Hashtbl.t -> 'a -> 'b -> unit", - "cost": 35 + "cost": 35, + "doc": "[Hashtbl.add tbl key data] adds a binding of [key] to [data] + in table [tbl]. + + {b Warning}: Previous bindings for [key] are not removed, but simply + hidden. That is, after performing {!remove}[ tbl key], + the previous binding for [key], if any, is restored. + (Same behavior as with association lists.) + + If you desire the classic behavior of replacing elements, + see {!replace}." }, { "file": "hashtbl.mli", @@ -139,7 +169,12 @@ }, "name": "Stdlib__Hashtbl.replace", "type": "('a, 'b) Stdlib__Hashtbl.t -> 'a -> 'b -> unit", - "cost": 36 + "cost": 36, + "doc": "[Hashtbl.replace tbl key data] replaces the current binding of [key] + in [tbl] by a binding of [key] to [data]. If [key] is unbound in [tbl], + a binding of [key] to [data] is added to [tbl]. + This is functionally equivalent to {!remove}[ tbl key] + followed by {!add}[ tbl key data]." }, { "file": "hashtbl.mli", @@ -153,7 +188,9 @@ }, "name": "Stdlib__Hashtbl.add_seq", "type": "('a, 'b) Stdlib__Hashtbl.t -> ('a * 'b) Seq.t -> unit", - "cost": 48 + "cost": 48, + "doc": "Add the given bindings to the table, using {!add} + @since 4.07" }, { "file": "hashtbl.mli", @@ -167,7 +204,9 @@ }, "name": "Stdlib__Hashtbl.replace_seq", "type": "('a, 'b) Stdlib__Hashtbl.t -> ('a * 'b) Seq.t -> unit", - "cost": 49 + "cost": 49, + "doc": "Add the given bindings to the table, using {!replace} + @since 4.07" }, { "file": "moreLabels.mli", @@ -181,7 +220,9 @@ }, "name": "Stdlib__MoreLabels.Hashtbl.add_seq", "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> ('a * 'b) Seq.t -> unit", - "cost": 50 + "cost": 50, + "doc": "Add the given bindings to the table, using {!add} + @since 4.07" }, { "file": "moreLabels.mli", @@ -195,7 +236,9 @@ }, "name": "Stdlib__MoreLabels.Hashtbl.replace_seq", "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> ('a * 'b) Seq.t -> unit", - "cost": 51 + "cost": 51, + "doc": "Add the given bindings to the table, using {!replace} + @since 4.07" }, { "file": "result.mli", @@ -209,7 +252,8 @@ }, "name": "Stdlib__Result.bind", "type": "('a, 'e) result -> ('a -> ('b, 'e) result) -> ('b, 'e) result", - "cost": 63 + "cost": 63, + "doc": "[bind r f] is [f v] if [r] is [Ok v] and [r] if [r] is [Error _]." }, { "file": "stdlib.mli", @@ -223,7 +267,8 @@ }, "name": "string_of_format", "type": "('a, 'b, 'c, 'd, 'e, 'f) format6 -> string", - "cost": 68 + "cost": 68, + "doc": "Converts a format string into a string." }, { "file": "stdlib.mli", @@ -237,7 +282,8 @@ }, "name": "string_of_format", "type": "('a, 'b, 'c, 'd, 'e, 'f) format6 -> string", - "cost": 68 + "cost": 68, + "doc": "Converts a format string into a string." }, { "file": "either.mli", @@ -253,7 +299,9 @@ "type": "left:('a1 -> 'a2) -> right:('b1 -> 'b2) -> ('a1, 'b1) Stdlib__Either.t -> ('a2, 'b2) Stdlib__Either.t", - "cost": 79 + "cost": 79, + "doc": "[map ~left ~right (Left v)] is [Left (left v)], + [map ~left ~right (Right v)] is [Right (right v)]." } ], "notifications": [] From 3d51670d05d8691fc0e295695c8c1fe7eeac10d7 Mon Sep 17 00:00:00 2001 From: xvw Date: Mon, 16 Sep 2024 16:10:27 +0200 Subject: [PATCH 06/24] Add search by types/by polarities comparison --- ...rity-search-comparison-to-search-by-type.t | 145 +++++++++++++++++ ...ch-by-type-comparison-to-polarity-search.t | 146 ++++++++++++++++++ 2 files changed, 291 insertions(+) create mode 100644 tests/test-dirs/polarity-search-comparison-to-search-by-type.t create mode 100644 tests/test-dirs/search-by-type-comparison-to-polarity-search.t diff --git a/tests/test-dirs/polarity-search-comparison-to-search-by-type.t b/tests/test-dirs/polarity-search-comparison-to-search-by-type.t new file mode 100644 index 000000000..e4a90f5f9 --- /dev/null +++ b/tests/test-dirs/polarity-search-comparison-to-search-by-type.t @@ -0,0 +1,145 @@ + $ cat >main.ml < let f x = succ x + > EOF + +1.) Looking for a function that convert a string to an integer (with +potential failures, so lifting the result in an int option). + + $ $MERLIN single search-by-polarity -filename ./main.ml \ + > -position 5:25 -query "-string +option" | + > tr '\n' ' ' | jq '.value.entries[:10][] | {name,desc}' + { + "name": "bool_of_string_opt", + "desc": "string -> bool option" + } + { + "name": "bool_of_string_opt", + "desc": "string -> bool option" + } + { + "name": "float_of_string_opt", + "desc": "string -> float option" + } + { + "name": "float_of_string_opt", + "desc": "string -> float option" + } + { + "name": "int_of_string_opt", + "desc": "string -> int option" + } + { + "name": "int_of_string_opt", + "desc": "string -> int option" + } + { + "name": "Stdlib__Float.of_string_opt", + "desc": "string -> float option" + } + { + "name": "Stdlib__Int32.of_string_opt", + "desc": "string -> int32 option" + } + { + "name": "Stdlib__Int64.of_string_opt", + "desc": "string -> int64 option" + } + { + "name": "Stdlib__Nativeint.of_string_opt", + "desc": "string -> nativeint option" + } + +2.) Looking for a function that take a list of list of flatten-it into +a list. + + $ $MERLIN single search-by-polarity -filename ./main.ml \ + > -position 5:25 -query "-list +list" | + > tr '\n' ' ' | jq '.value.entries[:10][] | {name,desc}' + { + "name": "Stdlib__List.rev", + "desc": "'a list -> 'a list" + } + { + "name": "Stdlib__List.tl", + "desc": "'a list -> 'a list" + } + { + "name": "Stdlib__ListLabels.rev", + "desc": "'a list -> 'a list" + } + { + "name": "Stdlib__ListLabels.tl", + "desc": "'a list -> 'a list" + } + { + "name": "Stdlib__List.concat", + "desc": "'a list list -> 'a list" + } + { + "name": "Stdlib__List.flatten", + "desc": "'a list list -> 'a list" + } + { + "name": "Stdlib__ListLabels.concat", + "desc": "'a list list -> 'a list" + } + { + "name": "Stdlib__ListLabels.flatten", + "desc": "'a list list -> 'a list" + } + { + "name": "Stdlib__List.cons", + "desc": "'a -> 'a list -> 'a list" + } + { + "name": "Stdlib__ListLabels.cons", + "desc": "'a -> 'a list -> 'a list" + } + +3.) Looking for a function that take a list and produce a new list +applying a function on every element for the given list (formerly +map). + + $ $MERLIN single search-by-polarity -filename ./main.ml \ + > -position 5:25 -query "-list -list +list" | + > tr '\n' ' ' | jq '.value.entries[:10][] | {name,desc}' + { + "name": "Stdlib__List.rev", + "desc": "'a list -> 'a list" + } + { + "name": "Stdlib__List.tl", + "desc": "'a list -> 'a list" + } + { + "name": "Stdlib__ListLabels.rev", + "desc": "'a list -> 'a list" + } + { + "name": "Stdlib__ListLabels.tl", + "desc": "'a list -> 'a list" + } + { + "name": "Stdlib__List.concat", + "desc": "'a list list -> 'a list" + } + { + "name": "Stdlib__List.flatten", + "desc": "'a list list -> 'a list" + } + { + "name": "Stdlib__ListLabels.concat", + "desc": "'a list list -> 'a list" + } + { + "name": "Stdlib__ListLabels.flatten", + "desc": "'a list list -> 'a list" + } + { + "name": "Stdlib__List.cons", + "desc": "'a -> 'a list -> 'a list" + } + { + "name": "Stdlib__ListLabels.cons", + "desc": "'a -> 'a list -> 'a list" + } 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 new file mode 100644 index 000000000..fb43246d9 --- /dev/null +++ b/tests/test-dirs/search-by-type-comparison-to-polarity-search.t @@ -0,0 +1,146 @@ + $ cat >main.ml < let f x = succ x + > EOF + +1.) Looking for a function that convert a string to an integer (with +potential failures, so lifting the result in an int option). + + $ $MERLIN single search-by-type -filename ./main.ml \ + > -position 5:25 -limit 10 -query "string -> int option" | + > tr '\n' ' ' | jq '.value[] | {name,type}' + { + "name": "int_of_string_opt", + "type": "string -> int option" + } + { + "name": "int_of_string_opt", + "type": "string -> int option" + } + { + "name": "Stdlib__Int32.of_string_opt", + "type": "string -> int32 option" + } + { + "name": "Stdlib__Int64.of_string_opt", + "type": "string -> int64 option" + } + { + "name": "bool_of_string_opt", + "type": "string -> bool option" + } + { + "name": "bool_of_string_opt", + "type": "string -> bool option" + } + { + "name": "float_of_string_opt", + "type": "string -> float option" + } + { + "name": "float_of_string_opt", + "type": "string -> float option" + } + { + "name": "Stdlib__Sys.getenv_opt", + "type": "string -> string option" + } + { + "name": "Stdlib__Float.of_string_opt", + "type": "string -> float option" + } + +2.) 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": "Stdlib__List.concat", + "type": "'a list list -> 'a list" + } + { + "name": "Stdlib__List.flatten", + "type": "'a list list -> 'a list" + } + { + "name": "Stdlib__ListLabels.concat", + "type": "'a list list -> 'a list" + } + { + "name": "Stdlib__ListLabels.flatten", + "type": "'a list list -> 'a list" + } + { + "name": "Stdlib__Array.concat", + "type": "'a array list -> 'a array" + } + { + "name": "Stdlib__ArrayLabels.concat", + "type": "'a array list -> 'a array" + } + { + "name": "Stdlib__Option.join", + "type": "'a option option -> 'a option" + } + { + "name": "Stdlib__Result.join", + "type": "(('a, 'e) result, 'e) result -> ('a, 'e) result" + } + { + "name": "Stdlib__Seq.concat", + "type": "'a Stdlib__Seq.t Stdlib__Seq.t -> 'a Stdlib__Seq.t" + } + { + "name": "Stdlib__Seq.transpose", + "type": "'a Stdlib__Seq.t Stdlib__Seq.t -> 'a Stdlib__Seq.t Stdlib__Seq.t" + } + +3.) Looking for a function that take a list and produce a new list +applying a function on every element for the given list (formerly +map). + + $ $MERLIN single search-by-type -filename ./main.ml \ + > -position 5:25 -limit 10 -query "'a list -> ('a -> 'b) -> 'b list" | + > tr '\n' ' ' | jq '.value[] | {name,type}' + { + "name": "Stdlib__List.map", + "type": "('a -> 'b) -> 'a list -> 'b list" + } + { + "name": "Stdlib__List.rev_map", + "type": "('a -> 'b) -> 'a list -> 'b list" + } + { + "name": "Stdlib__ListLabels.map", + "type": "f:('a -> 'b) -> 'a list -> 'b list" + } + { + "name": "Stdlib__ListLabels.rev_map", + "type": "f:('a -> 'b) -> 'a list -> 'b list" + } + { + "name": "Stdlib__List.mapi", + "type": "(int -> 'a -> 'b) -> 'a list -> 'b list" + } + { + "name": "Stdlib__ListLabels.mapi", + "type": "f:(int -> 'a -> 'b) -> 'a list -> 'b list" + } + { + "name": "Stdlib__List.concat_map", + "type": "('a -> 'b list) -> 'a list -> 'b list" + } + { + "name": "Stdlib__List.filter_map", + "type": "('a -> 'b option) -> 'a list -> 'b list" + } + { + "name": "Stdlib__ListLabels.concat_map", + "type": "f:('a -> 'b list) -> 'a list -> 'b list" + } + { + "name": "Stdlib__ListLabels.filter_map", + "type": "f:('a -> 'b option) -> 'a list -> 'b list" + } From 599d4f79779f9c507ad8c7913fb64851f43a1214 Mon Sep 17 00:00:00 2001 From: xvw Date: Mon, 16 Sep 2024 22:23:56 +0200 Subject: [PATCH 07/24] A very small emacs support for search by types --- emacs/merlin.el | 69 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 69 insertions(+) diff --git a/emacs/merlin.el b/emacs/merlin.el index f29aad7af..761ade252 100644 --- a/emacs/merlin.el +++ b/emacs/merlin.el @@ -141,6 +141,10 @@ See `merlin-debug'." "The name of the buffer displaying result of polarity search." :group 'merlin :type 'string) +(defcustom merlin-search-by-type-buffer-name "*merlin-search-by-type-result*" + "The name of the buffer displaying result of a search by type query." + :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,6 +1098,71 @@ An ocaml atom is any string containing [a-z_0-9A-Z`.]." (cons (if bounds (car bounds) (point)) (point)))) +;;;;;;;;;;;;;;;;;;;;; +;; SEARCH BY TYPE ;; +;;;;;;;;;;;;;;;;;;;;; + +(defun merlin--search-by-type (query) + (merlin-call "search-by-type" + "-query" query + "-position" (merlin-unmake-point (point)))) + +(defun merlin--get-search-by-type-result-buff () + (get-buffer-create merlin-search-by-type-buffer-name)) + +(defun merlin--search-result-wrap (text) + "Remove every newlines and trim tabulation." + (string-join (mapcar #'string-trim (string-lines text)) " ")) + +(defun merlin--search-trim-documentation (doc) + "Trim documentation block." + (string-join + (mapcar #'string-trim (string-lines doc)) "\n")) + +(defun merlin--search-result-doc (entry) + (let ((doc-entry (cdr (assoc 'doc entry)))) + (if (eq doc-entry 'null) + "" + (merlin--search-trim-documentation doc-entry)))) + +(defun merlin--render-search-result (name type docstring) + (let ((line + (concat + (propertize + name 'face (intern "font-lock-function-name-face")) + " : " + (propertize + (merlin--search-result-wrap type) + 'face (intern "font-lock-doc-face")) + "\n" + (propertize docstring 'face (intern "font-lock-comment-face")) + "\n\n"))) + (insert line))) + +(defun merlin--search-result-to-entry (entry) + (let ((function-name (cdr (assoc 'name entry))) + (function-type (cdr (assoc 'type entry))) + (function-docs (merlin--search-result-doc entry))) + (merlin--render-search-result + function-name + function-type + function-docs))) + +(defun merlin-search-by-type (query) + (interactive "sSearch query: ") + (let* ((result (merlin--search-by-type query)) + (previous-buffer (current-buffer))) + (let ((search-by-type-buffer (merlin--get-search-by-type-result-buff)) + (inhibit-read-only t)) + (with-current-buffer search-by-type-buffer + (switch-to-buffer-other-window search-by-type-buffer) + (erase-buffer) + (dolist (elt result) + (merlin--search-result-to-entry elt)) + (goto-char 1) + (switch-to-buffer-other-window previous-buffer))))) + + ;;;;;;;;;;;;;;;;;;;;; ;; POLARITY SEARCH ;; ;;;;;;;;;;;;;;;;;;;;; From 1cc043f0ad5e629e856b47af3adeddc342a8394e Mon Sep 17 00:00:00 2001 From: xvw Date: Tue, 17 Sep 2024 15:21:36 +0200 Subject: [PATCH 08/24] Resolve Module name in result --- emacs/merlin.el | 2 +- src/analysis/type_search.ml | 1 + src/analysis/type_search.mli | 2 +- ...ch-by-type-comparison-to-polarity-search.t | 56 +++++++------- tests/test-dirs/search-by-type.t/run.t | 76 +++++++++---------- 5 files changed, 69 insertions(+), 68 deletions(-) diff --git a/emacs/merlin.el b/emacs/merlin.el index 761ade252..5b3fadb55 100644 --- a/emacs/merlin.el +++ b/emacs/merlin.el @@ -1156,10 +1156,10 @@ An ocaml atom is any string containing [a-z_0-9A-Z`.]." (inhibit-read-only t)) (with-current-buffer search-by-type-buffer (switch-to-buffer-other-window search-by-type-buffer) - (erase-buffer) (dolist (elt result) (merlin--search-result-to-entry elt)) (goto-char 1) + (read-only-mode) (switch-to-buffer-other-window previous-buffer))))) diff --git a/src/analysis/type_search.ml b/src/analysis/type_search.ml index bc41d9da6..6597b370c 100644 --- a/src/analysis/type_search.ml +++ b/src/analysis/type_search.ml @@ -78,6 +78,7 @@ let run ?(limit = 100) config local_defs comments pos env query trie = Env.fold_values (fun _ path desc acc -> let open Merlin_sherlodoc in let typ = type_of desc.Types.val_type 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 diff --git a/src/analysis/type_search.mli b/src/analysis/type_search.mli index 16b5f7d3b..3246b9781 100644 --- a/src/analysis/type_search.mli +++ b/src/analysis/type_search.mli @@ -33,7 +33,7 @@ (** A Lazy trie of the potentials values. *) type t -(** Initiailzie the trie with a given list of directories. *) +(** 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. *) 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 fb43246d9..da2dc88b4 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 @@ -17,13 +17,17 @@ potential failures, so lifting the result in an int option). "type": "string -> int option" } { - "name": "Stdlib__Int32.of_string_opt", + "name": "Int32.of_string_opt", "type": "string -> int32 option" } { - "name": "Stdlib__Int64.of_string_opt", + "name": "Int64.of_string_opt", "type": "string -> int64 option" } + { + "name": "Sys.getenv_opt", + "type": "string -> string option" + } { "name": "bool_of_string_opt", "type": "string -> bool option" @@ -33,7 +37,7 @@ potential failures, so lifting the result in an int option). "type": "string -> bool option" } { - "name": "float_of_string_opt", + "name": "Float.of_string_opt", "type": "string -> float option" } { @@ -41,11 +45,7 @@ potential failures, so lifting the result in an int option). "type": "string -> float option" } { - "name": "Stdlib__Sys.getenv_opt", - "type": "string -> string option" - } - { - "name": "Stdlib__Float.of_string_opt", + "name": "float_of_string_opt", "type": "string -> float option" } @@ -57,43 +57,43 @@ a list. > -position 5:25 -limit 10 -query "'a list list -> 'a list" | > tr '\n' ' ' | jq '.value[] | {name,type}' { - "name": "Stdlib__List.concat", + "name": "List.concat", "type": "'a list list -> 'a list" } { - "name": "Stdlib__List.flatten", + "name": "List.flatten", "type": "'a list list -> 'a list" } { - "name": "Stdlib__ListLabels.concat", + "name": "ListLabels.concat", "type": "'a list list -> 'a list" } { - "name": "Stdlib__ListLabels.flatten", + "name": "ListLabels.flatten", "type": "'a list list -> 'a list" } { - "name": "Stdlib__Array.concat", + "name": "Array.concat", "type": "'a array list -> 'a array" } { - "name": "Stdlib__ArrayLabels.concat", + "name": "ArrayLabels.concat", "type": "'a array list -> 'a array" } { - "name": "Stdlib__Option.join", + "name": "Option.join", "type": "'a option option -> 'a option" } { - "name": "Stdlib__Result.join", + "name": "Result.join", "type": "(('a, 'e) result, 'e) result -> ('a, 'e) result" } { - "name": "Stdlib__Seq.concat", + "name": "Seq.concat", "type": "'a Stdlib__Seq.t Stdlib__Seq.t -> 'a Stdlib__Seq.t" } { - "name": "Stdlib__Seq.transpose", + "name": "Seq.transpose", "type": "'a Stdlib__Seq.t Stdlib__Seq.t -> 'a Stdlib__Seq.t Stdlib__Seq.t" } @@ -105,42 +105,42 @@ map). > -position 5:25 -limit 10 -query "'a list -> ('a -> 'b) -> 'b list" | > tr '\n' ' ' | jq '.value[] | {name,type}' { - "name": "Stdlib__List.map", + "name": "List.map", "type": "('a -> 'b) -> 'a list -> 'b list" } { - "name": "Stdlib__List.rev_map", + "name": "List.rev_map", "type": "('a -> 'b) -> 'a list -> 'b list" } { - "name": "Stdlib__ListLabels.map", + "name": "ListLabels.map", "type": "f:('a -> 'b) -> 'a list -> 'b list" } { - "name": "Stdlib__ListLabels.rev_map", + "name": "ListLabels.rev_map", "type": "f:('a -> 'b) -> 'a list -> 'b list" } { - "name": "Stdlib__List.mapi", + "name": "List.mapi", "type": "(int -> 'a -> 'b) -> 'a list -> 'b list" } { - "name": "Stdlib__ListLabels.mapi", + "name": "ListLabels.mapi", "type": "f:(int -> 'a -> 'b) -> 'a list -> 'b list" } { - "name": "Stdlib__List.concat_map", + "name": "List.concat_map", "type": "('a -> 'b list) -> 'a list -> 'b list" } { - "name": "Stdlib__List.filter_map", + "name": "List.filter_map", "type": "('a -> 'b option) -> 'a list -> 'b list" } { - "name": "Stdlib__ListLabels.concat_map", + "name": "ListLabels.concat_map", "type": "f:('a -> 'b list) -> 'a list -> 'b list" } { - "name": "Stdlib__ListLabels.filter_map", + "name": "ListLabels.filter_map", "type": "f:('a -> 'b option) -> 'a list -> 'b list" } diff --git a/tests/test-dirs/search-by-type.t/run.t b/tests/test-dirs/search-by-type.t/run.t index 2e282951f..8883afe9d 100644 --- a/tests/test-dirs/search-by-type.t/run.t +++ b/tests/test-dirs/search-by-type.t/run.t @@ -14,17 +14,23 @@ "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": "Stdlib__Int32.of_string_opt", + "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" } { - "name": "Stdlib__Int64.of_string_opt", + "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": "Sys.getenv_opt", + "type": "string -> string option", + "cost": 4, + "doc": "Return the value associated to a variable in the process environment or [None] if the variable is unbound. @since 4.05" + } { "name": "bool_of_string_opt", "type": "string -> bool option", @@ -38,10 +44,10 @@ "doc": "Convert the given string to a boolean. Return [None] if the string is not [\"true\"] or [\"false\"]. @since 4.05" } { - "name": "float_of_string_opt", + "name": "Float.of_string_opt", "type": "string -> float option", "cost": 4, - "doc": "Convert the given string to a float. The string is read in decimal (by default) or in hexadecimal (marked by [0x] or [0X]). The format of decimal floating-point numbers is [ [-] dd.ddd (e|E) [+|-] dd ], where [d] stands for a decimal digit. The format of hexadecimal floating-point numbers is [ [-] 0(x|X) hh.hhh (p|P) [+|-] dd ], where [h] stands for an hexadecimal digit and [d] for a decimal digit. In both cases, at least one of the integer and fractional parts must be given; the exponent part is optional. The [_] (underscore) character can appear anywhere in the string and is ignored. Depending on the execution platforms, other representations of floating-point numbers can be accepted, but should not be relied upon. Return [None] if the given string is not a valid representation of a float. @since 4.05" + "doc": "Same as [of_string], but returns [None] instead of raising." } { "name": "float_of_string_opt", @@ -50,16 +56,10 @@ "doc": "Convert the given string to a float. The string is read in decimal (by default) or in hexadecimal (marked by [0x] or [0X]). The format of decimal floating-point numbers is [ [-] dd.ddd (e|E) [+|-] dd ], where [d] stands for a decimal digit. The format of hexadecimal floating-point numbers is [ [-] 0(x|X) hh.hhh (p|P) [+|-] dd ], where [h] stands for an hexadecimal digit and [d] for a decimal digit. In both cases, at least one of the integer and fractional parts must be given; the exponent part is optional. The [_] (underscore) character can appear anywhere in the string and is ignored. Depending on the execution platforms, other representations of floating-point numbers can be accepted, but should not be relied upon. Return [None] if the given string is not a valid representation of a float. @since 4.05" } { - "name": "Stdlib__Sys.getenv_opt", - "type": "string -> string option", - "cost": 4, - "doc": "Return the value associated to a variable in the process environment or [None] if the variable is unbound. @since 4.05" - } - { - "name": "Stdlib__Float.of_string_opt", + "name": "float_of_string_opt", "type": "string -> float option", "cost": 4, - "doc": "Same as [of_string], but returns [None] instead of raising." + "doc": "Convert the given string to a float. The string is read in decimal (by default) or in hexadecimal (marked by [0x] or [0X]). The format of decimal floating-point numbers is [ [-] dd.ddd (e|E) [+|-] dd ], where [d] stands for a decimal digit. The format of hexadecimal floating-point numbers is [ [-] 0(x|X) hh.hhh (p|P) [+|-] dd ], where [h] stands for an hexadecimal digit and [d] for a decimal digit. In both cases, at least one of the integer and fractional parts must be given; the exponent part is optional. The [_] (underscore) character can appear anywhere in the string and is ignored. Depending on the execution platforms, other representations of floating-point numbers can be accepted, but should not be relied upon. Return [None] if the given string is not a valid representation of a float. @since 4.05" } @@ -67,61 +67,61 @@ > -position 5:25 -limit 10 -query "('a -> 'b) -> 'a list -> 'b list" | > tr '\n' ' ' | jq '.value[] | {name,type,cost,doc}' { - "name": "Stdlib__List.map", + "name": "List.map", "type": "('a -> 'b) -> 'a list -> 'b list", "cost": 0, "doc": "[map f [a1; ...; an]] applies function [f] to [a1, ..., an], and builds the list [[f a1; ...; f an]] with the results returned by [f]." } { - "name": "Stdlib__List.rev_map", + "name": "List.rev_map", "type": "('a -> 'b) -> 'a list -> 'b list", "cost": 0, "doc": "[rev_map f l] gives the same result as {!rev}[ (]{!map}[ f l)], but is more efficient." } { - "name": "Stdlib__ListLabels.map", + "name": "ListLabels.map", "type": "f:('a -> 'b) -> 'a list -> 'b list", "cost": 0, "doc": "[map ~f [a1; ...; an]] applies function [f] to [a1, ..., an], and builds the list [[f a1; ...; f an]] with the results returned by [f]." } { - "name": "Stdlib__ListLabels.rev_map", + "name": "ListLabels.rev_map", "type": "f:('a -> 'b) -> 'a list -> 'b list", "cost": 0, "doc": "[rev_map ~f l] gives the same result as {!rev}[ (]{!map}[ f l)], but is more efficient." } { - "name": "Stdlib__List.mapi", + "name": "List.mapi", "type": "(int -> 'a -> 'b) -> 'a list -> 'b list", "cost": 5, "doc": "Same as {!map}, but the function is applied to the index of the element as first argument (counting from 0), and the element itself as second argument. @since 4.00" } { - "name": "Stdlib__ListLabels.mapi", + "name": "ListLabels.mapi", "type": "f:(int -> 'a -> 'b) -> 'a list -> 'b list", "cost": 5, "doc": "Same as {!map}, but the function is applied to the index of the element as first argument (counting from 0), and the element itself as second argument. @since 4.00" } { - "name": "Stdlib__List.concat_map", + "name": "List.concat_map", "type": "('a -> 'b list) -> 'a list -> 'b list", "cost": 10, "doc": "[concat_map f l] gives the same result as {!concat}[ (]{!map}[ f l)]. Tail-recursive. @since 4.10" } { - "name": "Stdlib__List.filter_map", + "name": "List.filter_map", "type": "('a -> 'b option) -> 'a list -> 'b list", "cost": 10, "doc": "[filter_map f l] applies [f] to every element of [l], filters out the [None] elements and returns the list of the arguments of the [Some] elements. @since 4.08" } { - "name": "Stdlib__ListLabels.concat_map", + "name": "ListLabels.concat_map", "type": "f:('a -> 'b list) -> 'a list -> 'b list", "cost": 10, "doc": "[concat_map ~f l] gives the same result as {!concat}[ (]{!map}[ f l)]. Tail-recursive. @since 4.10" } { - "name": "Stdlib__ListLabels.filter_map", + "name": "ListLabels.filter_map", "type": "f:('a -> 'b option) -> 'a list -> 'b list", "cost": 10, "doc": "[filter_map ~f l] applies [f] to every element of [l], filters out the [None] elements and returns the list of the arguments of the [Some] elements. @since 4.08" @@ -143,9 +143,9 @@ "line": 116, "col": 40 }, - "name": "Stdlib__Hashtbl.add", + "name": "Hashtbl.add", "type": "('a, 'b) Stdlib__Hashtbl.t -> 'a -> 'b -> unit", - "cost": 35, + "cost": 33, "doc": "[Hashtbl.add tbl key data] adds a binding of [key] to [data] in table [tbl]. @@ -167,9 +167,9 @@ "line": 151, "col": 44 }, - "name": "Stdlib__Hashtbl.replace", + "name": "Hashtbl.replace", "type": "('a, 'b) Stdlib__Hashtbl.t -> 'a -> 'b -> unit", - "cost": 36, + "cost": 34, "doc": "[Hashtbl.replace tbl key data] replaces the current binding of [key] in [tbl] by a binding of [key] to [data]. If [key] is unbound in [tbl], a binding of [key] to [data] is added to [tbl]. @@ -186,9 +186,9 @@ "line": 301, "col": 50 }, - "name": "Stdlib__Hashtbl.add_seq", + "name": "Hashtbl.add_seq", "type": "('a, 'b) Stdlib__Hashtbl.t -> ('a * 'b) Seq.t -> unit", - "cost": 48, + "cost": 46, "doc": "Add the given bindings to the table, using {!add} @since 4.07" }, @@ -202,9 +202,9 @@ "line": 305, "col": 54 }, - "name": "Stdlib__Hashtbl.replace_seq", + "name": "Hashtbl.replace_seq", "type": "('a, 'b) Stdlib__Hashtbl.t -> ('a * 'b) Seq.t -> unit", - "cost": 49, + "cost": 47, "doc": "Add the given bindings to the table, using {!replace} @since 4.07" }, @@ -218,9 +218,9 @@ "line": 318, "col": 52 }, - "name": "Stdlib__MoreLabels.Hashtbl.add_seq", + "name": "MoreLabels.Hashtbl.add_seq", "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> ('a * 'b) Seq.t -> unit", - "cost": 50, + "cost": 48, "doc": "Add the given bindings to the table, using {!add} @since 4.07" }, @@ -234,9 +234,9 @@ "line": 322, "col": 56 }, - "name": "Stdlib__MoreLabels.Hashtbl.replace_seq", + "name": "MoreLabels.Hashtbl.replace_seq", "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> ('a * 'b) Seq.t -> unit", - "cost": 51, + "cost": 49, "doc": "Add the given bindings to the table, using {!replace} @since 4.07" }, @@ -250,9 +250,9 @@ "line": 47, "col": 72 }, - "name": "Stdlib__Result.bind", + "name": "Result.bind", "type": "('a, 'e) result -> ('a -> ('b, 'e) result) -> ('b, 'e) result", - "cost": 63, + "cost": 61, "doc": "[bind r f] is [f v] if [r] is [Ok v] and [r] if [r] is [Error _]." }, { @@ -295,11 +295,11 @@ "line": 87, "col": 73 }, - "name": "Stdlib__Either.map", + "name": "Either.map", "type": "left:('a1 -> 'a2) -> right:('b1 -> 'b2) -> ('a1, 'b1) Stdlib__Either.t -> ('a2, 'b2) Stdlib__Either.t", - "cost": 79, + "cost": 77, "doc": "[map ~left ~right (Left v)] is [Left (left v)], [map ~left ~right (Right v)] is [Right (right v)]." } From caeb3daa749320ca17211099f1824e5e23f79261 Mon Sep 17 00:00:00 2001 From: xvw Date: Wed, 18 Sep 2024 17:05:09 +0200 Subject: [PATCH 09/24] Simplify the result buffer of search And add the support of dynamic switching between search by types and search by polarity --- emacs/merlin.el | 100 +++++++++++++++++++++--------------------------- 1 file changed, 44 insertions(+), 56 deletions(-) diff --git a/emacs/merlin.el b/emacs/merlin.el index 5b3fadb55..c5c0f0988 100644 --- a/emacs/merlin.el +++ b/emacs/merlin.el @@ -1098,6 +1098,18 @@ An ocaml atom is any string containing [a-z_0-9A-Z`.]." (cons (if bounds (car bounds) (point)) (point)))) +;;;;;;;;;;;;;;;;;;;;; +;; COMMON SEARCH ;; +;;;;;;;;;;;;;;;;;;;;; + +(defun merlin--render-search-result (name type) + (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"))))) + ;;;;;;;;;;;;;;;;;;;;; ;; SEARCH BY TYPE ;; ;;;;;;;;;;;;;;;;;;;;; @@ -1110,58 +1122,32 @@ An ocaml atom is any string containing [a-z_0-9A-Z`.]." (defun merlin--get-search-by-type-result-buff () (get-buffer-create merlin-search-by-type-buffer-name)) -(defun merlin--search-result-wrap (text) - "Remove every newlines and trim tabulation." - (string-join (mapcar #'string-trim (string-lines text)) " ")) - -(defun merlin--search-trim-documentation (doc) - "Trim documentation block." - (string-join - (mapcar #'string-trim (string-lines doc)) "\n")) - -(defun merlin--search-result-doc (entry) - (let ((doc-entry (cdr (assoc 'doc entry)))) - (if (eq doc-entry 'null) - "" - (merlin--search-trim-documentation doc-entry)))) - -(defun merlin--render-search-result (name type docstring) - (let ((line - (concat - (propertize - name 'face (intern "font-lock-function-name-face")) - " : " - (propertize - (merlin--search-result-wrap type) - 'face (intern "font-lock-doc-face")) - "\n" - (propertize docstring 'face (intern "font-lock-comment-face")) - "\n\n"))) - (insert line))) - (defun merlin--search-result-to-entry (entry) (let ((function-name (cdr (assoc 'name entry))) - (function-type (cdr (assoc 'type entry))) - (function-docs (merlin--search-result-doc entry))) - (merlin--render-search-result + (function-type (cdr (assoc 'type entry)))) + (list function-name (vector (merlin--render-search-result function-name - function-type - function-docs))) + function-type))))) (defun merlin-search-by-type (query) (interactive "sSearch query: ") - (let* ((result (merlin--search-by-type query)) - (previous-buffer (current-buffer))) + (let ((entries (merlin--search-by-type query)) + (previous-buff (current-buffer))) (let ((search-by-type-buffer (merlin--get-search-by-type-result-buff)) - (inhibit-read-only t)) + (inhibit-read-only t)) (with-current-buffer search-by-type-buffer - (switch-to-buffer-other-window search-by-type-buffer) - (dolist (elt result) - (merlin--search-result-to-entry elt)) - (goto-char 1) - (read-only-mode) - (switch-to-buffer-other-window previous-buffer))))) - + (switch-to-buffer-other-window search-by-type-buffer) + (goto-char 1) + (tabulated-list-mode) + (setq tabulated-list-format [("Search By Type Result" 100 t)]) + (setq tabulated-list-entries + (mapcar 'merlin--search-result-to-entry 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))))) ;;;;;;;;;;;;;;;;;;;;; ;; POLARITY SEARCH ;; @@ -1175,22 +1161,14 @@ An ocaml atom is any string containing [a-z_0-9A-Z`.]." (defun merlin--get-polarity-buff () (get-buffer-create merlin-polarity-search-buffer-name)) -(defun merlin--render-polarity-result (name type) - (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))))) + (vector (merlin--render-search-result function-name function-type))))) -(defun merlin-search (query) - (interactive "sSearch pattern: ") +(defun merlin-search-by-polarity (query) + (interactive "sSearch query: ") (let* ((result (merlin--search query)) (entries (cdr (assoc 'entries result))) (previous-buff (current-buffer))) @@ -1201,7 +1179,8 @@ An ocaml atom is any string containing [a-z_0-9A-Z`.]." (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-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) @@ -1209,6 +1188,15 @@ An ocaml atom is any string containing [a-z_0-9A-Z`.]." (setq buffer-read-only t) (switch-to-buffer-other-window previous-buff))))) +(defun merlin--is-polarity-query (query) + (or (string-prefix-p "-" query) (string-prefix-p "+" query))) + +(defun merlin-search (query) + (interactive "sSearch query: ") + (if (merlin--is-polarity-query query) + (merlin-search-by-polarity query) + (merlin-search-by-type query))) + ;;;;;;;;;;;;;;;;; ;; TYPE BUFFER ;; ;;;;;;;;;;;;;;;;; From 09e0ca21043895257b844376421a9847c59a14c9 Mon Sep 17 00:00:00 2001 From: xvw Date: Wed, 18 Sep 2024 17:37:32 +0200 Subject: [PATCH 10/24] Improve constructor resolution --- src/analysis/type_search.ml | 5 +- ...ch-by-type-comparison-to-polarity-search.t | 24 +-- tests/test-dirs/search-by-type.t/run.t | 147 ++++++++++-------- 3 files changed, 95 insertions(+), 81 deletions(-) diff --git a/src/analysis/type_search.ml b/src/analysis/type_search.ml index 6597b370c..0a079ebb8 100644 --- a/src/analysis/type_search.ml +++ b/src/analysis/type_search.ml @@ -34,7 +34,7 @@ type trie = | T of string * Longident.t * t Lazy.t and t = trie list -let type_of typ = +let type_of env typ = let open Merlin_sherlodoc in let rec aux typ = match Types.get_desc typ with @@ -43,6 +43,7 @@ let type_of typ = | 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 @@ -77,7 +78,7 @@ 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 typ = type_of desc.Types.val_type in + let typ = type_of env desc.Types.val_type 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 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 da2dc88b4..d1234af2b 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 @@ -80,22 +80,22 @@ a list. "name": "ArrayLabels.concat", "type": "'a array list -> 'a array" } - { - "name": "Option.join", - "type": "'a option option -> 'a option" - } - { - "name": "Result.join", - "type": "(('a, 'e) result, 'e) result -> ('a, 'e) result" - } { "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" + } 3.) Looking for a function that take a list and produce a new list applying a function on every element for the given list (formerly @@ -128,6 +128,10 @@ map). "name": "ListLabels.mapi", "type": "f:(int -> 'a -> 'b) -> 'a list -> 'b list" } + { + "name": "Seq.map", + "type": "('a -> 'b) -> 'a Stdlib__Seq.t -> 'b Stdlib__Seq.t" + } { "name": "List.concat_map", "type": "('a -> 'b list) -> 'a list -> 'b list" @@ -140,7 +144,3 @@ map). "name": "ListLabels.concat_map", "type": "f:('a -> 'b list) -> 'a list -> 'b list" } - { - "name": "ListLabels.filter_map", - "type": "f:('a -> 'b option) -> 'a list -> 'b list" - } diff --git a/tests/test-dirs/search-by-type.t/run.t b/tests/test-dirs/search-by-type.t/run.t index 8883afe9d..1318c9d73 100644 --- a/tests/test-dirs/search-by-type.t/run.t +++ b/tests/test-dirs/search-by-type.t/run.t @@ -102,6 +102,12 @@ "cost": 5, "doc": "Same as {!map}, but the function is applied to the index of the element as first argument (counting from 0), and the element itself as second argument. @since 4.00" } + { + "name": "Seq.map", + "type": "('a -> 'b) -> 'a Stdlib__Seq.t -> 'b Stdlib__Seq.t", + "cost": 10, + "doc": "[map f xs] is the image of the sequence [xs] through the transformation [f]. If [xs] is the sequence [x0; x1; ...] then [map f xs] is the sequence [f x0; f x1; ...]." + } { "name": "List.concat_map", "type": "('a -> 'b list) -> 'a list -> 'b list", @@ -120,12 +126,6 @@ "cost": 10, "doc": "[concat_map ~f l] gives the same result as {!concat}[ (]{!map}[ f l)]. Tail-recursive. @since 4.10" } - { - "name": "ListLabels.filter_map", - "type": "f:('a -> 'b option) -> 'a list -> 'b list", - "cost": 10, - "doc": "[filter_map ~f l] applies [f] to every element of [l], filters out the [None] elements and returns the list of the arguments of the [Some] elements. @since 4.08" - } $ $MERLIN single search-by-type -filename ./context.ml \ > -position 5:25 -limit 10 \ @@ -145,7 +145,7 @@ }, "name": "Hashtbl.add", "type": "('a, 'b) Stdlib__Hashtbl.t -> 'a -> 'b -> unit", - "cost": 33, + "cost": 1, "doc": "[Hashtbl.add tbl key data] adds a binding of [key] to [data] in table [tbl]. @@ -169,7 +169,7 @@ }, "name": "Hashtbl.replace", "type": "('a, 'b) Stdlib__Hashtbl.t -> 'a -> 'b -> unit", - "cost": 34, + "cost": 2, "doc": "[Hashtbl.replace tbl key data] replaces the current binding of [key] in [tbl] by a binding of [key] to [data]. If [key] is unbound in [tbl], a binding of [key] to [data] is added to [tbl]. @@ -188,7 +188,7 @@ }, "name": "Hashtbl.add_seq", "type": "('a, 'b) Stdlib__Hashtbl.t -> ('a * 'b) Seq.t -> unit", - "cost": 46, + "cost": 24, "doc": "Add the given bindings to the table, using {!add} @since 4.07" }, @@ -204,104 +204,117 @@ }, "name": "Hashtbl.replace_seq", "type": "('a, 'b) Stdlib__Hashtbl.t -> ('a * 'b) Seq.t -> unit", - "cost": 47, + "cost": 25, "doc": "Add the given bindings to the table, using {!replace} @since 4.07" }, { - "file": "moreLabels.mli", + "file": "either.mli", "start": { - "line": 318, - "col": 2 + "line": 86, + "col": 0 }, "end": { - "line": 318, - "col": 52 + "line": 87, + "col": 73 }, - "name": "MoreLabels.Hashtbl.add_seq", - "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> ('a * 'b) Seq.t -> unit", - "cost": 48, - "doc": "Add the given bindings to the table, using {!add} - @since 4.07" + "name": "Either.map", + "type": "left:('a1 -> 'a2) -> + right:('b1 -> 'b2) -> + ('a1, 'b1) Stdlib__Either.t -> ('a2, 'b2) Stdlib__Either.t", + "cost": 44, + "doc": "[map ~left ~right (Left v)] is [Left (left v)], + [map ~left ~right (Right v)] is [Right (right v)]." }, { "file": "moreLabels.mli", "start": { - "line": 322, + "line": 133, "col": 2 }, "end": { - "line": 322, - "col": 56 + "line": 133, + "col": 51 }, - "name": "MoreLabels.Hashtbl.replace_seq", - "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> ('a * 'b) Seq.t -> unit", - "cost": 49, - "doc": "Add the given bindings to the table, using {!replace} - @since 4.07" + "name": "MoreLabels.Hashtbl.add", + "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> key:'a -> data:'b -> unit", + "cost": 47, + "doc": "[Hashtbl.add tbl ~key ~data] adds a binding of [key] to [data] + in table [tbl]. + + {b Warning}: Previous bindings for [key] are not removed, but simply + hidden. That is, after performing {!remove}[ tbl key], + the previous binding for [key], if any, is restored. + (Same behavior as with association lists.) + + If you desire the classic behavior of replacing elements, + see {!replace}." }, { - "file": "result.mli", + "file": "moreLabels.mli", "start": { - "line": 47, - "col": 0 + "line": 318, + "col": 2 }, "end": { - "line": 47, - "col": 72 + "line": 318, + "col": 52 }, - "name": "Result.bind", - "type": "('a, 'e) result -> ('a -> ('b, 'e) result) -> ('b, 'e) result", - "cost": 61, - "doc": "[bind r f] is [f v] if [r] is [Ok v] and [r] if [r] is [Error _]." + "name": "MoreLabels.Hashtbl.add_seq", + "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> ('a * 'b) Seq.t -> unit", + "cost": 48, + "doc": "Add the given bindings to the table, using {!add} + @since 4.07" }, { - "file": "stdlib.mli", + "file": "moreLabels.mli", "start": { - "line": 1324, - "col": 0 + "line": 168, + "col": 2 }, "end": { - "line": 1324, - "col": 65 + "line": 168, + "col": 55 }, - "name": "string_of_format", - "type": "('a, 'b, 'c, 'd, 'e, 'f) format6 -> string", - "cost": 68, - "doc": "Converts a format string into a string." + "name": "MoreLabels.Hashtbl.replace", + "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> key:'a -> data:'b -> unit", + "cost": 48, + "doc": "[Hashtbl.replace tbl ~key ~data] replaces the current binding of [key] + in [tbl] by a binding of [key] to [data]. If [key] is unbound in [tbl], + a binding of [key] to [data] is added to [tbl]. + This is functionally equivalent to {!remove}[ tbl key] + followed by {!add}[ tbl key data]." }, { - "file": "stdlib.mli", + "file": "moreLabels.mli", "start": { - "line": 1324, - "col": 0 + "line": 322, + "col": 2 }, "end": { - "line": 1324, - "col": 65 + "line": 322, + "col": 56 }, - "name": "string_of_format", - "type": "('a, 'b, 'c, 'd, 'e, 'f) format6 -> string", - "cost": 68, - "doc": "Converts a format string into a string." + "name": "MoreLabels.Hashtbl.replace_seq", + "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> ('a * 'b) Seq.t -> unit", + "cost": 49, + "doc": "Add the given bindings to the table, using {!replace} + @since 4.07" }, { - "file": "either.mli", + "file": "ephemeron.mli", "start": { - "line": 86, - "col": 0 + "line": 203, + "col": 2 }, "end": { - "line": 87, - "col": 73 + "line": 203, + "col": 55 }, - "name": "Either.map", - "type": "left:('a1 -> 'a2) -> - right:('b1 -> 'b2) -> - ('a1, 'b1) Stdlib__Either.t -> ('a2, 'b2) Stdlib__Either.t", - "cost": 77, - "doc": "[map ~left ~right (Left v)] is [Left (left v)], - [map ~left ~right (Right v)] is [Right (right v)]." + "name": "Ephemeron.K2.query", + "type": "('k1, 'k2, 'd) Stdlib__Ephemeron.K2.t -> 'k1 -> 'k2 -> 'd option", + "cost": 53, + "doc": "Same as {!Ephemeron.K1.query}" } ], "notifications": [] From ec1db8a09f3183610e67ff05802fd44f61ee8ec6 Mon Sep 17 00:00:00 2001 From: xvw Date: Wed, 18 Sep 2024 18:10:29 +0200 Subject: [PATCH 11/24] Add CHANGES entry --- CHANGES.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index a54e083bc..72cf20366 100644 --- a/CHANGES.md +++ b/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 ========== From ecfc26c443a2c36378dcf7501c8246ac286a5503 Mon Sep 17 00:00:00 2001 From: xvw Date: Thu, 19 Sep 2024 22:14:05 +0200 Subject: [PATCH 12/24] Add function documentation --- emacs/merlin.el | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/emacs/merlin.el b/emacs/merlin.el index c5c0f0988..1fa0c9c69 100644 --- a/emacs/merlin.el +++ b/emacs/merlin.el @@ -1130,9 +1130,10 @@ An ocaml atom is any string containing [a-z_0-9A-Z`.]." function-type))))) (defun merlin-search-by-type (query) + "Search a value definition by type expression" (interactive "sSearch query: ") (let ((entries (merlin--search-by-type query)) - (previous-buff (current-buffer))) + (previous-buff (current-buffer))) (let ((search-by-type-buffer (merlin--get-search-by-type-result-buff)) (inhibit-read-only t)) (with-current-buffer search-by-type-buffer @@ -1168,6 +1169,7 @@ An ocaml atom is any string containing [a-z_0-9A-Z`.]." (vector (merlin--render-search-result function-name function-type))))) (defun merlin-search-by-polarity (query) + "Search a value definition by polarity" (interactive "sSearch query: ") (let* ((result (merlin--search query)) (entries (cdr (assoc 'entries result))) @@ -1192,6 +1194,7 @@ An ocaml atom is any string containing [a-z_0-9A-Z`.]." (or (string-prefix-p "-" query) (string-prefix-p "+" query))) (defun merlin-search (query) + "Search a value defintion by polarity or by type expression" (interactive "sSearch query: ") (if (merlin--is-polarity-query query) (merlin-search-by-polarity query) From 76dfdd1f345e9e868dbfa0ecbbd1f78395464b6e Mon Sep 17 00:00:00 2001 From: xvw Date: Wed, 18 Sep 2024 19:31:15 +0200 Subject: [PATCH 13/24] Add a constructible expression --- src/analysis/type_search.ml | 29 +++++++++++++++++++++---- src/analysis/type_search.mli | 2 +- src/commands/query_json.ml | 5 +++-- src/frontend/query_commands.ml | 4 ++-- src/frontend/query_protocol.ml | 3 ++- tests/test-dirs/search-by-type.t/run.t | 30 +++++++++++++++++--------- 6 files changed, 53 insertions(+), 20 deletions(-) diff --git a/src/analysis/type_search.ml b/src/analysis/type_search.ml index 0a079ebb8..b5d58415e 100644 --- a/src/analysis/type_search.ml +++ b/src/analysis/type_search.ml @@ -47,7 +47,26 @@ let type_of env typ = 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 + 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 make_trie env modules = let rec walk env lident = @@ -78,7 +97,8 @@ 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 typ = type_of env desc.Types.val_type 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 @@ -94,7 +114,8 @@ let run ?(limit = 100) config local_defs comments pos env query trie = (`User_input path) |> doc_to_option in - (cost, path, desc, doc) :: acc + let constructible = make_constructible path d in + (cost, path, desc, doc, constructible) :: acc ) dir env acc in let rec walk acc (T (_, dir, children)) = @@ -111,7 +132,7 @@ 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) -> + |> 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 diff --git a/src/analysis/type_search.mli b/src/analysis/type_search.mli index 3246b9781..de0ed1165 100644 --- a/src/analysis/type_search.mli +++ b/src/analysis/type_search.mli @@ -46,4 +46,4 @@ val run : Env.t -> Merlin_sherlodoc.Query_parser.t -> t - -> (int * string * Types.value_description * string option) list + -> (int * string * Types.value_description * string option * string) list diff --git a/src/commands/query_json.ml b/src/commands/query_json.ml index 5280907ce..a229a0311 100644 --- a/src/commands/query_json.ml +++ b/src/commands/query_json.ml @@ -381,7 +381,7 @@ let json_of_signature_help resp = let json_of_search_result list = let list = List.map - ~f:(fun { name; typ; loc; cost; doc } -> + ~f:(fun { name; typ; loc; cost; doc; constructible } -> with_location ~with_file:true loc [ ("name", `String name); ("type", `String typ); @@ -389,7 +389,8 @@ let json_of_search_result list = ( "doc", match doc with | Some x -> `String x - | None -> `Null ) + | None -> `Null ); + ("constructible", `String constructible) ]) list in diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index 012a89c83..850b10fd9 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -493,14 +493,14 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function let verbosity = verbosity pipeline in Printtyp.wrap_printing_env ~verbosity env (fun () -> List.map - ~f:(fun (cost, name, typ, doc) -> + ~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 }) + { name; typ; cost; loc; doc; constructible }) result) | Refactor_open (mode, pos) -> let typer = Mpipeline.typer_result pipeline in diff --git a/src/frontend/query_protocol.ml b/src/frontend/query_protocol.ml index 8941860d8..821b10f44 100644 --- a/src/frontend/query_protocol.ml +++ b/src/frontend/query_protocol.ml @@ -72,7 +72,8 @@ type type_search_result = typ : string; loc : Location_aux.t; doc : string option; - cost : int + cost : int; + constructible : string } type outline = item list diff --git a/tests/test-dirs/search-by-type.t/run.t b/tests/test-dirs/search-by-type.t/run.t index 1318c9d73..ac5d162a6 100644 --- a/tests/test-dirs/search-by-type.t/run.t +++ b/tests/test-dirs/search-by-type.t/run.t @@ -155,7 +155,8 @@ (Same behavior as with association lists.) If you desire the classic behavior of replacing elements, - see {!replace}." + see {!replace}.", + "constructible": "Hashtbl.add _ _ _" }, { "file": "hashtbl.mli", @@ -174,7 +175,8 @@ in [tbl] by a binding of [key] to [data]. If [key] is unbound in [tbl], a binding of [key] to [data] is added to [tbl]. This is functionally equivalent to {!remove}[ tbl key] - followed by {!add}[ tbl key data]." + followed by {!add}[ tbl key data].", + "constructible": "Hashtbl.replace _ _ _" }, { "file": "hashtbl.mli", @@ -190,7 +192,8 @@ "type": "('a, 'b) Stdlib__Hashtbl.t -> ('a * 'b) Seq.t -> unit", "cost": 24, "doc": "Add the given bindings to the table, using {!add} - @since 4.07" + @since 4.07", + "constructible": "Hashtbl.add_seq _ _" }, { "file": "hashtbl.mli", @@ -206,7 +209,8 @@ "type": "('a, 'b) Stdlib__Hashtbl.t -> ('a * 'b) Seq.t -> unit", "cost": 25, "doc": "Add the given bindings to the table, using {!replace} - @since 4.07" + @since 4.07", + "constructible": "Hashtbl.replace_seq _ _" }, { "file": "either.mli", @@ -224,7 +228,8 @@ ('a1, 'b1) Stdlib__Either.t -> ('a2, 'b2) Stdlib__Either.t", "cost": 44, "doc": "[map ~left ~right (Left v)] is [Left (left v)], - [map ~left ~right (Right v)] is [Right (right v)]." + [map ~left ~right (Right v)] is [Right (right v)].", + "constructible": "Either.map ~left:_ ~right:_ _" }, { "file": "moreLabels.mli", @@ -248,7 +253,8 @@ (Same behavior as with association lists.) If you desire the classic behavior of replacing elements, - see {!replace}." + see {!replace}.", + "constructible": "MoreLabels.Hashtbl.add _ ~key:_ ~data:_" }, { "file": "moreLabels.mli", @@ -264,7 +270,8 @@ "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> ('a * 'b) Seq.t -> unit", "cost": 48, "doc": "Add the given bindings to the table, using {!add} - @since 4.07" + @since 4.07", + "constructible": "MoreLabels.Hashtbl.add_seq _ _" }, { "file": "moreLabels.mli", @@ -283,7 +290,8 @@ in [tbl] by a binding of [key] to [data]. If [key] is unbound in [tbl], a binding of [key] to [data] is added to [tbl]. This is functionally equivalent to {!remove}[ tbl key] - followed by {!add}[ tbl key data]." + followed by {!add}[ tbl key data].", + "constructible": "MoreLabels.Hashtbl.replace _ ~key:_ ~data:_" }, { "file": "moreLabels.mli", @@ -299,7 +307,8 @@ "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> ('a * 'b) Seq.t -> unit", "cost": 49, "doc": "Add the given bindings to the table, using {!replace} - @since 4.07" + @since 4.07", + "constructible": "MoreLabels.Hashtbl.replace_seq _ _" }, { "file": "ephemeron.mli", @@ -314,7 +323,8 @@ "name": "Ephemeron.K2.query", "type": "('k1, 'k2, 'd) Stdlib__Ephemeron.K2.t -> 'k1 -> 'k2 -> 'd option", "cost": 53, - "doc": "Same as {!Ephemeron.K1.query}" + "doc": "Same as {!Ephemeron.K1.query}", + "constructible": "Ephemeron.K2.query _ _ _" } ], "notifications": [] From 116a4327cbd79ddd8fd7471867bfe4b7cc7b0704 Mon Sep 17 00:00:00 2001 From: xvw Date: Fri, 20 Sep 2024 14:04:41 +0200 Subject: [PATCH 14/24] Allows a search by type to be searched by polarity --- src/analysis/polarity_search.ml | 54 +++++++++++ src/analysis/type_search.ml | 32 ++++--- src/analysis/type_search.mli | 9 ++ src/frontend/query_commands.ml | 30 +++--- ...ch-by-type-comparison-to-polarity-search.t | 96 +++++++++++++++++++ 5 files changed, 190 insertions(+), 31 deletions(-) diff --git a/src/analysis/polarity_search.ml b/src/analysis/polarity_search.ml index 4f23bceef..3f1896fb4 100644 --- a/src/analysis/polarity_search.ml +++ b/src/analysis/polarity_search.ml @@ -83,6 +83,19 @@ 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 +142,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 diff --git a/src/analysis/type_search.ml b/src/analysis/type_search.ml index b5d58415e..80d15d7e0 100644 --- a/src/analysis/type_search.ml +++ b/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 diff --git a/src/analysis/type_search.mli b/src/analysis/type_search.mli index de0ed1165..f8b02e045 100644 --- a/src/analysis/type_search.mli +++ b/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 ] diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index 850b10fd9..3f43792a2 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -444,21 +444,7 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function 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 @@ -477,7 +463,6 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function in { 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 @@ -486,10 +471,19 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function 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 + 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 () -> List.map 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 d1234af2b..0654dbb1f 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 @@ -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" + } From 83d3c6abc6d95958cbe89300fbc7586bfa54a7ff Mon Sep 17 00:00:00 2001 From: xvw Date: Fri, 20 Sep 2024 17:48:10 +0200 Subject: [PATCH 15/24] Simplify the search buffer --- emacs/merlin.el | 155 +++++++++++++++++------------------------------- 1 file changed, 55 insertions(+), 100 deletions(-) diff --git a/emacs/merlin.el b/emacs/merlin.el index 1fa0c9c69..d90f6625d 100644 --- a/emacs/merlin.el +++ b/emacs/merlin.el @@ -137,14 +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-search-by-type-buffer-name "*merlin-search-by-type-result*" - "The name of the buffer displaying result of a search by type query." - :group 'merlin :type 'string) - (defcustom merlin-favourite-caml-mode nil "The OCaml mode to use for the *merlin-types* buffer." :group 'merlin :type 'symbol) @@ -1098,107 +1090,70 @@ An ocaml atom is any string containing [a-z_0-9A-Z`.]." (cons (if bounds (car bounds) (point)) (point)))) -;;;;;;;;;;;;;;;;;;;;; -;; COMMON SEARCH ;; -;;;;;;;;;;;;;;;;;;;;; -(defun merlin--render-search-result (name type) - (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"))))) - -;;;;;;;;;;;;;;;;;;;;; -;; SEARCH BY TYPE ;; -;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;; +;; SEARCH ;; +;;;;;;;;;;;; -(defun merlin--search-by-type (query) +(defun merlin--search (query) (merlin-call "search-by-type" "-query" query "-position" (merlin-unmake-point (point)))) -(defun merlin--get-search-by-type-result-buff () - (get-buffer-create merlin-search-by-type-buffer-name)) - -(defun merlin--search-result-to-entry (entry) - (let ((function-name (cdr (assoc 'name entry))) - (function-type (cdr (assoc 'type entry)))) - (list function-name (vector (merlin--render-search-result - function-name - function-type))))) - -(defun merlin-search-by-type (query) - "Search a value definition by type expression" - (interactive "sSearch query: ") - (let ((entries (merlin--search-by-type query)) - (previous-buff (current-buffer))) - (let ((search-by-type-buffer (merlin--get-search-by-type-result-buff)) - (inhibit-read-only t)) - (with-current-buffer search-by-type-buffer - (switch-to-buffer-other-window search-by-type-buffer) - (goto-char 1) - (tabulated-list-mode) - (setq tabulated-list-format [("Search By Type Result" 100 t)]) - (setq tabulated-list-entries - (mapcar 'merlin--search-result-to-entry 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))))) - -;;;;;;;;;;;;;;;;;;;;; -;; POLARITY SEARCH ;; -;;;;;;;;;;;;;;;;;;;;; - -(defun merlin--search (query) - (merlin-call "search-by-polarity" - "-query" query - "-position" (merlin-unmake-point (point)))) - -(defun merlin--get-polarity-buff () - (get-buffer-create merlin-polarity-search-buffer-name)) - -(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-search-result function-name function-type))))) - -(defun merlin-search-by-polarity (query) - "Search a value definition by polarity" - (interactive "sSearch query: ") - (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))))) - -(defun merlin--is-polarity-query (query) - (or (string-prefix-p "-" query) (string-prefix-p "+" query))) +(defun merlin--search-format-key (name type doc) + (let ((plain-name (string-remove-prefix "Stdlib__" name))) + (concat + (propertize plain-name 'face (intern "font-lock-function-name-face")) + " : " + (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) - "Search a value defintion by polarity or by type expression" + "Search values by types or polarity" (interactive "sSearch query: ") - (if (merlin--is-polarity-query query) - (merlin-search-by-polarity query) - (merlin-search-by-type 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 ;; From 89d4aa45f2a63847d5fef6a5bf0f0d234a24df74 Mon Sep 17 00:00:00 2001 From: xvw Date: Fri, 20 Sep 2024 23:41:21 +0200 Subject: [PATCH 16/24] 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 3f43792a2..620d8ebba 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -475,8 +475,7 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function 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 + Type_search.run ~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" } From 10a79489a7e9d7e1c50d95e9312f5e3473acde0e Mon Sep 17 00:00:00 2001 From: xvw Date: Mon, 23 Sep 2024 16:58:31 +0200 Subject: [PATCH 17/24] Add polarity search and type search in protocol --- doc/dev/PROTOCOL.md | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/doc/dev/PROTOCOL.md b/doc/dev/PROTOCOL.md index 7d03d986f..286875837 100644 --- a/doc/dev/PROTOCOL.md +++ b/doc/dev/PROTOCOL.md @@ -425,6 +425,34 @@ 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 -query + + -position Position to search + -query 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 -query -limit + + -position Position to search + -query The query + -limit a maximum-size of the result set + +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` From 79548c29039bd69f8331f4671151b6df1c7dc69f Mon Sep 17 00:00:00 2001 From: xvw Date: Mon, 23 Sep 2024 17:53:29 +0200 Subject: [PATCH 18/24] 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 | 28 ++++--------- 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, 81 insertions(+), 61 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 3f1896fb4..844af7aa3 100644 --- a/src/analysis/polarity_search.ml +++ b/src/analysis/polarity_search.ml @@ -144,14 +144,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 @@ -159,11 +166,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 @@ -179,7 +192,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 620d8ebba..cb330f5d3 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -471,30 +471,18 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function let config = Mpipeline.final_config pipeline in let comments = Mpipeline.reader_comments pipeline in let modules = Mconfig.global_modules config in - let result = + begin match Type_search.classify_query query with | `By_type query -> - let query = Merlin_sherlodoc.Query_parser.from_string query in - Type_search.run ~limit config local_defs comments pos env query modules + let query = Merlin_sherlodoc.Query.from_string query in + Type_search.run ~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 - 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) + 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 ~modules () + end | Refactor_open (mode, pos) -> let typer = Mpipeline.typer_result pipeline in let pos = Mpipeline.get_lexing_pos pipeline pos 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; ] From 4febfc8cb85d1158337b4d88048073fe3f186424 Mon Sep 17 00:00:00 2001 From: xvw Date: Tue, 24 Sep 2024 14:40:36 +0200 Subject: [PATCH 19/24] Include `with-doc` arg for search by type --- .ocamlformat | 2 +- .ocamlformat-enable | 2 - CHANGES.md | 2 +- doc/dev/PROTOCOL.md | 3 +- src/analysis/polarity_search.ml | 21 +- src/analysis/type_search.ml | 52 +++-- src/analysis/type_search.mli | 17 +- src/commands/query_json.ml | 5 +- src/frontend/query_commands.ml | 18 +- src/frontend/query_protocol.ml | 4 +- ...ch-by-type-comparison-to-polarity-search.t | 12 +- tests/test-dirs/search-by-type.t/run.t | 192 +++++++++++------- 12 files changed, 176 insertions(+), 154 deletions(-) delete mode 100644 .ocamlformat-enable diff --git a/.ocamlformat b/.ocamlformat index 2f1d4222b..10492f340 100644 --- a/.ocamlformat +++ b/.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 \ No newline at end of file diff --git a/.ocamlformat-enable b/.ocamlformat-enable deleted file mode 100644 index a4c62a180..000000000 --- a/.ocamlformat-enable +++ /dev/null @@ -1,2 +0,0 @@ -src/sherlodoc/** -tests/test-units/** \ No newline at end of file diff --git a/CHANGES.md b/CHANGES.md index 72cf20366..c9a76ea71 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -8,7 +8,7 @@ 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) + - 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) diff --git a/doc/dev/PROTOCOL.md b/doc/dev/PROTOCOL.md index 286875837..16fac57f0 100644 --- a/doc/dev/PROTOCOL.md +++ b/doc/dev/PROTOCOL.md @@ -432,11 +432,12 @@ Returns the type of the expression when typechecked in the environment around th 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 -query -limit +### `search-by-type` -position -query -limit -with-doc -position Position to search -query The query -limit a maximum-size of the result set + -with-doc 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. diff --git a/src/analysis/polarity_search.ml b/src/analysis/polarity_search.ml index 844af7aa3..afc78f06d 100644 --- a/src/analysis/polarity_search.ml +++ b/src/analysis/polarity_search.ml @@ -143,15 +143,7 @@ let execute_query query env dirs = 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 - ~modules () = +let execute_query_as_type_search ?(limit = 100) ~env ~query ~modules doc_ctx = let direct dir acc = Env.fold_values (fun _ path desc acc -> let d = desc.Types.val_type in @@ -159,16 +151,7 @@ let execute_query_as_type_search | Some cost -> let path = Printtyp.rewrite_double_underscore_paths env path in let name = Format.asprintf "%a" Printtyp.path path in - let doc = - Locate.get_doc - ~config - ~env - ~local_defs - ~comments - ~pos - (`User_input name) - |> Type_search.doc_to_option - in + let doc = Type_search.get_doc doc_ctx env name in let loc = desc.Types.val_loc in let typ = Format.asprintf "%a" diff --git a/src/analysis/type_search.ml b/src/analysis/type_search.ml index 30a343849..a80b3de47 100644 --- a/src/analysis/type_search.ml +++ b/src/analysis/type_search.ml @@ -70,6 +70,20 @@ let doc_to_option = function | `Found doc -> Some doc | _ -> None + +let get_doc doc_ctx env name = + match doc_ctx with + | None -> None + | Some (config, local_defs, comments, pos) -> + 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; _} @@ -85,9 +99,7 @@ let compare_result | _ -> c else c -let compute_value - (config, local_defs, comments, pos, query) env - _ path desc acc = +let compute_value doc_ctx 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 @@ -96,16 +108,7 @@ let compute_value let cost = Query.distance_for query ~path:name typ in if cost >= 1000 then acc else - let doc = - Locate.get_doc - ~config - ~env - ~local_defs - ~comments - ~pos - (`User_input name) - |> doc_to_option - in + let doc = get_doc doc_ctx env name in let loc = desc.Types.val_loc in let typ = Format.asprintf "%a" @@ -115,15 +118,15 @@ let compute_value 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 +let compute_values doc_ctx query env lident acc = + Env.fold_values (compute_value doc_ctx query env) lident env acc -let values_from_module ctx env lident acc = +let values_from_module doc_ctx query 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 + let acc = compute_values doc_ctx query env (Some lident) acc in Env.fold_modules (fun name _ mdl acc -> match mdl.Types.md_type with | Types.Mty_alias _ -> acc @@ -135,23 +138,14 @@ let values_from_module ctx env lident acc = 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 +let run ?(limit = 100) ~env ~query ~modules doc_ctx = + let init = compute_values doc_ctx query 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 + values_from_module doc_ctx query env lident acc ) |> List.sort ~cmp:compare_result |> List.take_n limit diff --git a/src/analysis/type_search.mli b/src/analysis/type_search.mli index 0c28ed383..5596cefdb 100644 --- a/src/analysis/type_search.mli +++ b/src/analysis/type_search.mli @@ -33,17 +33,22 @@ (** Compute the list of candidates from a query inside a given environment. *) val run : ?limit:int -> - 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 + -> (Mconfig.t + * Mtyper.typedtree + * (string * Location.t) list + * Lexing.position) + option -> Query_protocol.type_search_result list -val doc_to_option : [> `Builtin of string | `Found of string ] -> string option +val get_doc : + (Mconfig.t + * Mtyper.typedtree + * (string * Warnings.loc) list + * Lexing.position) option -> Env.t -> string -> string option + val make_constructible : string -> Types.type_expr -> string val compare_result : Query_protocol.type_search_result -> diff --git a/src/commands/query_json.ml b/src/commands/query_json.ml index a229a0311..b2b0fb5e3 100644 --- a/src/commands/query_json.ml +++ b/src/commands/query_json.ml @@ -178,11 +178,12 @@ let dump (type a) : a t -> json = | Polarity_search (query, pos) -> mk "polarity-search" [ ("query", `String query); ("position", mk_position pos) ] - | Type_search (query, pos, limit) -> + | Type_search (query, pos, limit, with_doc) -> mk "type-search" [ ("query", `String query); ("position", mk_position pos); - ("limit", `Int limit) + ("limit", `Int limit); + ("with-doc", `Bool with_doc) ] | Occurrences (`Ident_at pos, scope) -> mk "occurrences" diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index cb330f5d3..37d8c57ae 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -462,26 +462,30 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function { Compl.name; kind = `Value; desc; info = ""; deprecated = false }) in { Compl.entries; context = `Unknown } - | Type_search (query, pos, limit) -> + | Type_search (query, pos, limit, with_doc) -> let typer = Mpipeline.typer_result pipeline in - let local_defs = Mtyper.get_typedtree typer in let pos = Mpipeline.get_lexing_pos pipeline pos in let node = Mtyper.node_at typer pos in let env, _ = Mbrowse.leaf_node node in let config = Mpipeline.final_config pipeline in - let comments = Mpipeline.reader_comments pipeline in let modules = Mconfig.global_modules config in + let doc_ctx = + if with_doc then + let comments = Mpipeline.reader_comments pipeline in + let local_defs = Mtyper.get_typedtree typer in + Some (config, local_defs, comments, pos) + else None + in begin match Type_search.classify_query query with | `By_type query -> let query = Merlin_sherlodoc.Query.from_string query in - Type_search.run ~limit ~config ~local_defs ~comments ~pos ~env ~query - ~modules () + Type_search.run ~limit ~env ~query ~modules doc_ctx | `Polarity query -> let query = Polarity_search.prepare_query env query 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 ~modules () + Polarity_search.execute_query_as_type_search ~limit ~env ~query ~modules + doc_ctx end | Refactor_open (mode, pos) -> let typer = Mpipeline.typer_result pipeline in diff --git a/src/frontend/query_protocol.ml b/src/frontend/query_protocol.ml index 821b10f44..0616a3feb 100644 --- a/src/frontend/query_protocol.ml +++ b/src/frontend/query_protocol.ml @@ -148,7 +148,9 @@ type _ t = string * Msource.position * Compl.kind list * [ `with_types ] _bool -> completions t | Polarity_search : string * Msource.position -> completions t - | Type_search : string * Msource.position * int -> type_search_result list t + | Type_search : + string * Msource.position * int * bool + -> type_search_result list t | Refactor_open : [ `Qualify | `Unqualify ] * Msource.position -> (string * Location.t) list t 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 31048d7aa..dc5aa5f88 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 @@ -132,17 +132,17 @@ map). "name": "Seq.map", "type": "('a -> 'b) -> 'a Stdlib__Seq.t -> 'b Stdlib__Seq.t" } - { - "name": "List.concat_map", - "type": "('a -> 'b list) -> 'a list -> 'b list" - } { "name": "List.filter_map", "type": "('a -> 'b option) -> 'a list -> 'b list" } { - "name": "ListLabels.concat_map", - "type": "f:('a -> 'b list) -> 'a list -> 'b list" + "name": "List.concat_map", + "type": "('a -> 'b list) -> 'a list -> 'b list" + } + { + "name": "ListLabels.filter_map", + "type": "f:('a -> 'b option) -> 'a list -> 'b list" } diff --git a/tests/test-dirs/search-by-type.t/run.t b/tests/test-dirs/search-by-type.t/run.t index e9f36f47f..849b3de60 100644 --- a/tests/test-dirs/search-by-type.t/run.t +++ b/tests/test-dirs/search-by-type.t/run.t @@ -5,61 +5,61 @@ "name": "int_of_string_opt", "type": "string -> int option", "cost": 0, - "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" + "doc": null } { "name": "int_of_string_opt", "type": "string -> int option", "cost": 0, - "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" + "doc": null } { "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" + "doc": null } { "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" + "doc": null } { "name": "Sys.getenv_opt", "type": "string -> string option", "cost": 4, - "doc": "Return the value associated to a variable in the process environment or [None] if the variable is unbound. @since 4.05" + "doc": null } { "name": "bool_of_string_opt", "type": "string -> bool option", "cost": 4, - "doc": "Convert the given string to a boolean. Return [None] if the string is not [\"true\"] or [\"false\"]. @since 4.05" + "doc": null } { "name": "bool_of_string_opt", "type": "string -> bool option", "cost": 4, - "doc": "Convert the given string to a boolean. Return [None] if the string is not [\"true\"] or [\"false\"]. @since 4.05" + "doc": null } { "name": "Float.of_string_opt", "type": "string -> float option", "cost": 4, - "doc": "Same as [of_string], but returns [None] instead of raising." + "doc": null } { "name": "float_of_string_opt", "type": "string -> float option", "cost": 4, - "doc": "Convert the given string to a float. The string is read in decimal (by default) or in hexadecimal (marked by [0x] or [0X]). The format of decimal floating-point numbers is [ [-] dd.ddd (e|E) [+|-] dd ], where [d] stands for a decimal digit. The format of hexadecimal floating-point numbers is [ [-] 0(x|X) hh.hhh (p|P) [+|-] dd ], where [h] stands for an hexadecimal digit and [d] for a decimal digit. In both cases, at least one of the integer and fractional parts must be given; the exponent part is optional. The [_] (underscore) character can appear anywhere in the string and is ignored. Depending on the execution platforms, other representations of floating-point numbers can be accepted, but should not be relied upon. Return [None] if the given string is not a valid representation of a float. @since 4.05" + "doc": null } { "name": "float_of_string_opt", "type": "string -> float option", "cost": 4, - "doc": "Convert the given string to a float. The string is read in decimal (by default) or in hexadecimal (marked by [0x] or [0X]). The format of decimal floating-point numbers is [ [-] dd.ddd (e|E) [+|-] dd ], where [d] stands for a decimal digit. The format of hexadecimal floating-point numbers is [ [-] 0(x|X) hh.hhh (p|P) [+|-] dd ], where [h] stands for an hexadecimal digit and [d] for a decimal digit. In both cases, at least one of the integer and fractional parts must be given; the exponent part is optional. The [_] (underscore) character can appear anywhere in the string and is ignored. Depending on the execution platforms, other representations of floating-point numbers can be accepted, but should not be relied upon. Return [None] if the given string is not a valid representation of a float. @since 4.05" + "doc": null } @@ -70,61 +70,61 @@ "name": "List.map", "type": "('a -> 'b) -> 'a list -> 'b list", "cost": 0, - "doc": "[map f [a1; ...; an]] applies function [f] to [a1, ..., an], and builds the list [[f a1; ...; f an]] with the results returned by [f]." + "doc": null } { "name": "List.rev_map", "type": "('a -> 'b) -> 'a list -> 'b list", "cost": 0, - "doc": "[rev_map f l] gives the same result as {!rev}[ (]{!map}[ f l)], but is more efficient." + "doc": null } { "name": "ListLabels.map", "type": "f:('a -> 'b) -> 'a list -> 'b list", "cost": 0, - "doc": "[map ~f [a1; ...; an]] applies function [f] to [a1, ..., an], and builds the list [[f a1; ...; f an]] with the results returned by [f]." + "doc": null } { "name": "ListLabels.rev_map", "type": "f:('a -> 'b) -> 'a list -> 'b list", "cost": 0, - "doc": "[rev_map ~f l] gives the same result as {!rev}[ (]{!map}[ f l)], but is more efficient." + "doc": null } { "name": "List.mapi", "type": "(int -> 'a -> 'b) -> 'a list -> 'b list", "cost": 5, - "doc": "Same as {!map}, but the function is applied to the index of the element as first argument (counting from 0), and the element itself as second argument. @since 4.00" + "doc": null } { "name": "ListLabels.mapi", "type": "f:(int -> 'a -> 'b) -> 'a list -> 'b list", "cost": 5, - "doc": "Same as {!map}, but the function is applied to the index of the element as first argument (counting from 0), and the element itself as second argument. @since 4.00" + "doc": null } { "name": "Seq.map", "type": "('a -> 'b) -> 'a Stdlib__Seq.t -> 'b Stdlib__Seq.t", "cost": 10, - "doc": "[map f xs] is the image of the sequence [xs] through the transformation [f]. If [xs] is the sequence [x0; x1; ...] then [map f xs] is the sequence [f x0; f x1; ...]." + "doc": null } { - "name": "List.concat_map", - "type": "('a -> 'b list) -> 'a list -> 'b list", + "name": "List.filter_map", + "type": "('a -> 'b option) -> 'a list -> 'b list", "cost": 10, - "doc": "[concat_map f l] gives the same result as {!concat}[ (]{!map}[ f l)]. Tail-recursive. @since 4.10" + "doc": null } { - "name": "List.filter_map", - "type": "('a -> 'b option) -> 'a list -> 'b list", + "name": "List.concat_map", + "type": "('a -> 'b list) -> 'a list -> 'b list", "cost": 10, - "doc": "[filter_map f l] applies [f] to every element of [l], filters out the [None] elements and returns the list of the arguments of the [Some] elements. @since 4.08" + "doc": null } { - "name": "ListLabels.concat_map", - "type": "f:('a -> 'b list) -> 'a list -> 'b list", + "name": "ListLabels.filter_map", + "type": "f:('a -> 'b option) -> 'a list -> 'b list", "cost": 10, - "doc": "[concat_map ~f l] gives the same result as {!concat}[ (]{!map}[ f l)]. Tail-recursive. @since 4.10" + "doc": null } $ $MERLIN single search-by-type -filename ./context.ml \ @@ -146,16 +146,7 @@ "name": "Hashtbl.add", "type": "('a, 'b) Stdlib__Hashtbl.t -> 'a -> 'b -> unit", "cost": 1, - "doc": "[Hashtbl.add tbl key data] adds a binding of [key] to [data] - in table [tbl]. - - {b Warning}: Previous bindings for [key] are not removed, but simply - hidden. That is, after performing {!remove}[ tbl key], - the previous binding for [key], if any, is restored. - (Same behavior as with association lists.) - - If you desire the classic behavior of replacing elements, - see {!replace}.", + "doc": null, "constructible": "Hashtbl.add _ _ _" }, { @@ -171,11 +162,7 @@ "name": "Hashtbl.replace", "type": "('a, 'b) Stdlib__Hashtbl.t -> 'a -> 'b -> unit", "cost": 2, - "doc": "[Hashtbl.replace tbl key data] replaces the current binding of [key] - in [tbl] by a binding of [key] to [data]. If [key] is unbound in [tbl], - a binding of [key] to [data] is added to [tbl]. - This is functionally equivalent to {!remove}[ tbl key] - followed by {!add}[ tbl key data].", + "doc": null, "constructible": "Hashtbl.replace _ _ _" }, { @@ -191,8 +178,7 @@ "name": "Hashtbl.add_seq", "type": "('a, 'b) Stdlib__Hashtbl.t -> ('a * 'b) Seq.t -> unit", "cost": 24, - "doc": "Add the given bindings to the table, using {!add} - @since 4.07", + "doc": null, "constructible": "Hashtbl.add_seq _ _" }, { @@ -208,8 +194,7 @@ "name": "Hashtbl.replace_seq", "type": "('a, 'b) Stdlib__Hashtbl.t -> ('a * 'b) Seq.t -> unit", "cost": 25, - "doc": "Add the given bindings to the table, using {!replace} - @since 4.07", + "doc": null, "constructible": "Hashtbl.replace_seq _ _" }, { @@ -227,8 +212,7 @@ right:('b1 -> 'b2) -> ('a1, 'b1) Stdlib__Either.t -> ('a2, 'b2) Stdlib__Either.t", "cost": 44, - "doc": "[map ~left ~right (Left v)] is [Left (left v)], - [map ~left ~right (Right v)] is [Right (right v)].", + "doc": null, "constructible": "Either.map ~left:_ ~right:_ _" }, { @@ -244,54 +228,40 @@ "name": "MoreLabels.Hashtbl.add", "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> key:'a -> data:'b -> unit", "cost": 47, - "doc": "[Hashtbl.add tbl ~key ~data] adds a binding of [key] to [data] - in table [tbl]. - - {b Warning}: Previous bindings for [key] are not removed, but simply - hidden. That is, after performing {!remove}[ tbl key], - the previous binding for [key], if any, is restored. - (Same behavior as with association lists.) - - If you desire the classic behavior of replacing elements, - see {!replace}.", + "doc": null, "constructible": "MoreLabels.Hashtbl.add _ ~key:_ ~data:_" }, { "file": "moreLabels.mli", "start": { - "line": 318, + "line": 168, "col": 2 }, "end": { - "line": 318, - "col": 52 + "line": 168, + "col": 55 }, - "name": "MoreLabels.Hashtbl.add_seq", - "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> ('a * 'b) Seq.t -> unit", + "name": "MoreLabels.Hashtbl.replace", + "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> key:'a -> data:'b -> unit", "cost": 48, - "doc": "Add the given bindings to the table, using {!add} - @since 4.07", - "constructible": "MoreLabels.Hashtbl.add_seq _ _" + "doc": null, + "constructible": "MoreLabels.Hashtbl.replace _ ~key:_ ~data:_" }, { "file": "moreLabels.mli", "start": { - "line": 168, + "line": 318, "col": 2 }, "end": { - "line": 168, - "col": 55 + "line": 318, + "col": 52 }, - "name": "MoreLabels.Hashtbl.replace", - "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> key:'a -> data:'b -> unit", + "name": "MoreLabels.Hashtbl.add_seq", + "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> ('a * 'b) Seq.t -> unit", "cost": 48, - "doc": "[Hashtbl.replace tbl ~key ~data] replaces the current binding of [key] - in [tbl] by a binding of [key] to [data]. If [key] is unbound in [tbl], - a binding of [key] to [data] is added to [tbl]. - This is functionally equivalent to {!remove}[ tbl key] - followed by {!add}[ tbl key data].", - "constructible": "MoreLabels.Hashtbl.replace _ ~key:_ ~data:_" + "doc": null, + "constructible": "MoreLabels.Hashtbl.add_seq _ _" }, { "file": "moreLabels.mli", @@ -306,8 +276,7 @@ "name": "MoreLabels.Hashtbl.replace_seq", "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> ('a * 'b) Seq.t -> unit", "cost": 49, - "doc": "Add the given bindings to the table, using {!replace} - @since 4.07", + "doc": null, "constructible": "MoreLabels.Hashtbl.replace_seq _ _" }, { @@ -323,9 +292,74 @@ "name": "Ephemeron.K2.query", "type": "('k1, 'k2, 'd) Stdlib__Ephemeron.K2.t -> 'k1 -> 'k2 -> 'd option", "cost": 53, - "doc": "Same as {!Ephemeron.K1.query}", + "doc": null, "constructible": "Ephemeron.K2.query _ _ _" } ], "notifications": [] } + + + $ $MERLIN single search-by-type -filename ./context.ml \ + > -position 5:25 -limit 10 -with-doc true -query "string -> int option" | + > tr '\n' ' ' | jq '.value[] | {name,type,cost,doc}' + { + "name": "int_of_string_opt", + "type": "string -> int option", + "cost": 0, + "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": "int_of_string_opt", + "type": "string -> int option", + "cost": 0, + "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": "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": "Int32.of_string_opt", + "type": "string -> int32 option", + "cost": 2, + "doc": "Same as [of_string], but return [None] instead of raising. @since 4.05" + } + { + "name": "Sys.getenv_opt", + "type": "string -> string option", + "cost": 4, + "doc": "Return the value associated to a variable in the process environment or [None] if the variable is unbound. @since 4.05" + } + { + "name": "bool_of_string_opt", + "type": "string -> bool option", + "cost": 4, + "doc": "Convert the given string to a boolean. Return [None] if the string is not [\"true\"] or [\"false\"]. @since 4.05" + } + { + "name": "bool_of_string_opt", + "type": "string -> bool option", + "cost": 4, + "doc": "Convert the given string to a boolean. Return [None] if the string is not [\"true\"] or [\"false\"]. @since 4.05" + } + { + "name": "Float.of_string_opt", + "type": "string -> float option", + "cost": 4, + "doc": "Same as [of_string], but returns [None] instead of raising." + } + { + "name": "float_of_string_opt", + "type": "string -> float option", + "cost": 4, + "doc": "Convert the given string to a float. The string is read in decimal (by default) or in hexadecimal (marked by [0x] or [0X]). The format of decimal floating-point numbers is [ [-] dd.ddd (e|E) [+|-] dd ], where [d] stands for a decimal digit. The format of hexadecimal floating-point numbers is [ [-] 0(x|X) hh.hhh (p|P) [+|-] dd ], where [h] stands for an hexadecimal digit and [d] for a decimal digit. In both cases, at least one of the integer and fractional parts must be given; the exponent part is optional. The [_] (underscore) character can appear anywhere in the string and is ignored. Depending on the execution platforms, other representations of floating-point numbers can be accepted, but should not be relied upon. Return [None] if the given string is not a valid representation of a float. @since 4.05" + } + { + "name": "float_of_string_opt", + "type": "string -> float option", + "cost": 4, + "doc": "Convert the given string to a float. The string is read in decimal (by default) or in hexadecimal (marked by [0x] or [0X]). The format of decimal floating-point numbers is [ [-] dd.ddd (e|E) [+|-] dd ], where [d] stands for a decimal digit. The format of hexadecimal floating-point numbers is [ [-] 0(x|X) hh.hhh (p|P) [+|-] dd ], where [h] stands for an hexadecimal digit and [d] for a decimal digit. In both cases, at least one of the integer and fractional parts must be given; the exponent part is optional. The [_] (underscore) character can appear anywhere in the string and is ignored. Depending on the execution platforms, other representations of floating-point numbers can be accepted, but should not be relied upon. Return [None] if the given string is not a valid representation of a float. @since 4.05" + } From e02e44cd3fcbc6b36ac47e55f50e2f652fa7d324 Mon Sep 17 00:00:00 2001 From: xvw Date: Tue, 24 Sep 2024 16:28:25 +0200 Subject: [PATCH 20/24] Apply OCamlformat --- src/analysis/polarity_search.ml | 25 ++-- src/analysis/type_search.ml | 114 +++++++--------- src/analysis/type_search.mli | 83 ++++++------ src/sherlodoc/name_cost.ml | 12 +- src/sherlodoc/name_cost.mli | 6 +- src/sherlodoc/query.ml | 18 +-- src/sherlodoc/query.mli | 10 +- src/sherlodoc/type_distance.ml | 126 +++++++++--------- src/sherlodoc/type_distance.mli | 2 +- src/sherlodoc/type_expr.ml | 40 +++--- src/sherlodoc/type_expr.mli | 8 +- src/sherlodoc/type_parsed.mli | 2 +- src/sherlodoc/type_polarity.mli | 8 +- src/utils/marg.ml | 10 +- tests/test-units/sherldoc/name_cost_test.ml | 10 +- tests/test-units/sherldoc/query_test.ml | 5 +- tests/test-units/sherldoc/sherlodoc_test.ml | 5 +- .../test-units/sherldoc/type_distance_test.ml | 5 +- tests/test-units/sherldoc/type_expr_test.ml | 5 +- 19 files changed, 237 insertions(+), 257 deletions(-) diff --git a/src/analysis/polarity_search.ml b/src/analysis/polarity_search.ml index afc78f06d..2c7ada451 100644 --- a/src/analysis/polarity_search.ml +++ b/src/analysis/polarity_search.ml @@ -85,15 +85,17 @@ let build_query ~positive ~negative env = 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 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) + 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) + build_query env ~positive:(List.map pos ~f:prepare) ~negative:(List.map neg ~f:prepare) let directories ~global_modules env = @@ -145,8 +147,9 @@ let execute_query query env dirs = let execute_query_as_type_search ?(limit = 100) ~env ~query ~modules doc_ctx = let direct dir acc = - Env.fold_values (fun _ path desc acc -> - let d = desc.Types.val_type in + 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 @@ -159,9 +162,9 @@ let execute_query_as_type_search ?(limit = 100) ~env ~query ~modules doc_ctx = 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 + Query_protocol.{ cost; name; typ; loc; doc; constructible } :: acc + | None -> acc) + dir env acc in let rec recurse acc (Trie (_, dir, children)) = match diff --git a/src/analysis/type_search.ml b/src/analysis/type_search.ml index a80b3de47..9ab04e5f1 100644 --- a/src/analysis/type_search.ml +++ b/src/analysis/type_search.ml @@ -1,37 +1,37 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2024 Frédéric Bour - Thomas Refis - Simon Castellan - Arthur Wendling - Xavier Van de Woestyne - - 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. - - )* }}} *) + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2024 Frédéric Bour + Thomas Refis + Simon Castellan + Arthur Wendling + Xavier Van de Woestyne + + 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 open Merlin_sherlodoc in let rec aux typ = match Types.get_desc typ with | Types.Tvar None -> Type_parsed.Wildcard @@ -43,15 +43,16 @@ let sherlodoc_type_of env typ = 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 + in + typ |> aux |> Type_expr.normalize_type_parameters let make_constructible path desc = - let holes = match Types.get_desc desc with + 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 + | Types.Tarrow (l, _, b, _) -> aux (acc ^ with_label l) b | _ -> acc and with_label l = match l with @@ -64,38 +65,26 @@ let make_constructible path desc = in path ^ holes - let doc_to_option = function - | `Builtin doc - | `Found doc -> Some doc + | `Builtin doc | `Found doc -> Some doc | _ -> None - let get_doc doc_ctx env name = match doc_ctx with | None -> None | Some (config, local_defs, comments, pos) -> - Locate.get_doc - ~config - ~env - ~local_defs - ~comments - ~pos - (`User_input 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 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 + 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) + | 0, Some a, Some b -> Int.compare (String.length a) (String.length b) | _ -> c else c @@ -116,7 +105,7 @@ let compute_value doc_ctx query env _ path desc acc = desc.Types.val_type in let constructible = make_constructible name d in - Query_protocol.{cost; name; typ; loc; doc; constructible} :: acc + Query_protocol.{ cost; name; typ; loc; doc; constructible } :: acc let compute_values doc_ctx query env lident acc = Env.fold_values (compute_value doc_ctx query env) lident env acc @@ -125,36 +114,31 @@ let values_from_module doc_ctx query env lident acc = let rec aux acc lident = match Env.find_module_by_name lident env with | exception _ -> acc - | _ -> + | _ -> let acc = compute_values doc_ctx query env (Some lident) acc in - Env.fold_modules (fun name _ mdl acc -> + 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 + aux acc lident) + (Some lident) env acc in aux acc lident - let run ?(limit = 100) ~env ~query ~modules doc_ctx = let init = compute_values doc_ctx query env None [] in modules - |> List.fold_left - ~init - ~f:(fun acc name -> - let lident = Longident.Lident name in - values_from_module doc_ctx query env lident acc - ) + |> List.fold_left ~init ~f:(fun acc name -> + let lident = Longident.Lident name in + values_from_module doc_ctx 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 - + | exception Invalid_argument _ -> `Polarity query diff --git a/src/analysis/type_search.mli b/src/analysis/type_search.mli index 5596cefdb..a4dc9dd51 100644 --- a/src/analysis/type_search.mli +++ b/src/analysis/type_search.mli @@ -1,32 +1,32 @@ (* {{{ COPYING *( - This file is part of Merlin, an helper for ocaml editors - - Copyright (C) 2013 - 2024 Frédéric Bour - Thomas Refis - Simon Castellan - Arthur Wendling - Xavier Van de Woestyne - - 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. - - )* }}} *) + This file is part of Merlin, an helper for ocaml editors + + Copyright (C) 2013 - 2024 Frédéric Bour + Thomas Refis + Simon Castellan + Arthur Wendling + Xavier Van de Woestyne + + 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. + + )* }}} *) (** Search by type in the current environment. *) @@ -34,25 +34,24 @@ val run : ?limit:int -> env:Env.t -> - query:Merlin_sherlodoc.Query.t - -> modules:string list - -> (Mconfig.t - * Mtyper.typedtree - * (string * Location.t) list - * Lexing.position) - option - -> Query_protocol.type_search_result list + query:Merlin_sherlodoc.Query.t -> + modules:string list -> + (Mconfig.t * Mtyper.typedtree * (string * Location.t) list * Lexing.position) + option -> + Query_protocol.type_search_result list val get_doc : (Mconfig.t - * Mtyper.typedtree - * (string * Warnings.loc) list - * Lexing.position) option -> Env.t -> string -> string option - + * Mtyper.typedtree + * (string * Warnings.loc) list + * Lexing.position) + option -> + Env.t -> + string -> + string option + val make_constructible : string -> Types.type_expr -> string val compare_result : - Query_protocol.type_search_result -> - Query_protocol.type_search_result -> - int + 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/sherlodoc/name_cost.ml b/src/sherlodoc/name_cost.ml index ef2dd143a..c69009cfc 100644 --- a/src/sherlodoc/name_cost.ml +++ b/src/sherlodoc/name_cost.ml @@ -92,11 +92,11 @@ let best_distance ?cutoff words entry = let rec aux acc = function | [] -> acc |> Option.value ~default:0 | x :: xs -> ( - match distance_of_substring ?cutoff x entry with - | None -> aux acc xs - | Some 0 -> 0 - | Some x -> - let acc = Int.min x (Option.value ~default:x acc) in - aux (Some acc) xs) + match distance_of_substring ?cutoff x entry with + | None -> aux acc xs + | Some 0 -> 0 + | Some x -> + let acc = Int.min x (Option.value ~default:x acc) in + aux (Some acc) xs) in aux None words diff --git a/src/sherlodoc/name_cost.mli b/src/sherlodoc/name_cost.mli index 28f943fca..51a7b90b0 100644 --- a/src/sherlodoc/name_cost.mli +++ b/src/sherlodoc/name_cost.mli @@ -28,15 +28,15 @@ (** Utilities for calculating distances between names. *) -val distance : ?cutoff:int -> string -> string -> int option (** [distance ?cutoff a b] returns the {{:https://en.wikipedia.org/wiki/Damerau%E2%80%93Levenshtein_distance} Damerau-Levenshtein} between [a] and [b]. *) +val distance : ?cutoff:int -> string -> string -> int option -val distance_of_substring : ?cutoff:int -> string -> string -> int option (** [distance_of_substring ?cutoff a b] compute the distance by extracting relevant substring from [b] *) +val distance_of_substring : ?cutoff:int -> string -> string -> int option -val best_distance : ?cutoff:int -> string list -> string -> int (** [best_distance ?cutoff words entry] compute the best distance of a list of string according to a given string. *) +val best_distance : ?cutoff:int -> string list -> string -> int diff --git a/src/sherlodoc/query.ml b/src/sherlodoc/query.ml index 121c538b5..8d81d50ea 100644 --- a/src/sherlodoc/query.ml +++ b/src/sherlodoc/query.ml @@ -70,16 +70,16 @@ let from_string str = let words, type_expr = match String.index_opt str ':' with | None -> - if guess_type_search len str then - let str = balance_parens len str in - ("", Type_expr.from_string str) - else (str, None) + if guess_type_search len str then + let str = balance_parens len str in + ("", Type_expr.from_string str) + else (str, None) | Some loc -> - let str_name = String.sub str 0 loc - and str_type = String.sub str (succ loc) (len - loc - 1) in - let len = String.length str_type in - let str_type = balance_parens len str_type in - (str_name, Type_expr.from_string str_type) + let str_name = String.sub str 0 loc + and str_type = String.sub str (succ loc) (len - loc - 1) in + let len = String.length str_type in + let str_type = balance_parens len str_type in + (str_name, Type_expr.from_string str_type) in let words = naive_of_string words in { words; type_expr } diff --git a/src/sherlodoc/query.mli b/src/sherlodoc/query.mli index 71999ff8b..2cd5cd316 100644 --- a/src/sherlodoc/query.mli +++ b/src/sherlodoc/query.mli @@ -29,18 +29,18 @@ (** Prepares a query based on a string of characters. A query acts on the identifier of a function and its type.. *) -type t = { words : string list; type_expr : Type_expr.t option } (** Describes a search on an identifier and a type. *) +type t = { words : string list; type_expr : Type_expr.t option } -val from_string : string -> t (** Converts a string into a search query. *) +val from_string : string -> t -val to_string : t -> string (** Inspect a query (mostly for debugging purpose). *) +val to_string : t -> string -val equal : t -> t -> bool (** Equality between queries. *) +val equal : t -> t -> bool -val distance_for : t -> path:string -> Type_expr.t -> int (** [distance_for query ~path typexpr] returns a score for a [query] observing a given value, (a [path] and a [type_expr]). *) +val distance_for : t -> path:string -> Type_expr.t -> int diff --git a/src/sherlodoc/type_distance.ml b/src/sherlodoc/type_distance.ml index 60dbda453..7a3481dd1 100644 --- a/src/sherlodoc/type_distance.ml +++ b/src/sherlodoc/type_distance.ml @@ -43,25 +43,25 @@ let make_path t = | Type_expr.Wildcard -> [ Wildcard :: prefix ] | Type_expr.Tyvar x -> [ Tyvar x :: prefix ] | Type_expr.Arrow (a, b) -> - List.rev_append - (aux (Left_arrow :: prefix) a) - (aux (Right_arrow :: prefix) b) + List.rev_append + (aux (Left_arrow :: prefix) a) + (aux (Right_arrow :: prefix) b) | Type_expr.Tycon (constr, []) -> [ Tyname constr :: prefix ] | Type_expr.Tycon (constr, args) -> - let length = String.length constr in - let prefix = Tyname constr :: prefix in - args - |> List.mapi (fun position arg -> - let prefix = Argument { position; length } :: prefix in - aux prefix arg) - |> List.fold_left (fun acc xs -> List.rev_append xs acc) [] + let length = String.length constr in + let prefix = Tyname constr :: prefix in + args + |> List.mapi (fun position arg -> + let prefix = Argument { position; length } :: prefix in + aux prefix arg) + |> List.fold_left (fun acc xs -> List.rev_append xs acc) [] | Type_expr.Tuple args -> - let length = List.length args in - args - |> List.mapi (fun position arg -> - let prefix = Product { position; length } :: prefix in - aux prefix arg) - |> List.fold_left (fun acc xs -> List.rev_append xs acc) [] + let length = List.length args in + args + |> List.mapi (fun position arg -> + let prefix = Product { position; length } :: prefix in + aux prefix arg) + |> List.fold_left (fun acc xs -> List.rev_append xs acc) [] in List.map List.rev (aux [] t) @@ -90,31 +90,31 @@ let distance xs ys = | _, [] -> max_distance | [ Tyvar _ ], [ Wildcard ] when P.equal xpolarity ypolarity -> 0 | [ Tyvar x ], [ Tyvar y ] when P.equal xpolarity ypolarity -> - if Int.equal x y then 0 else 1 + if Int.equal x y then 0 else 1 | Left_arrow :: xs, Left_arrow :: ys -> - let xpolarity = P.negate xpolarity and ypolarity = P.negate ypolarity in - memo ~xpolarity ~ypolarity (succ i) (succ j) xs ys + let xpolarity = P.negate xpolarity and ypolarity = P.negate ypolarity in + memo ~xpolarity ~ypolarity (succ i) (succ j) xs ys | Left_arrow :: xs, _ -> - let xpolarity = P.negate xpolarity in - memo ~xpolarity ~ypolarity (succ i) j xs ys + let xpolarity = P.negate xpolarity in + memo ~xpolarity ~ypolarity (succ i) j xs ys | _, Left_arrow :: ys -> - let ypolarity = P.negate ypolarity in - memo ~xpolarity ~ypolarity i (succ j) xs ys + let ypolarity = P.negate ypolarity in + memo ~xpolarity ~ypolarity i (succ j) xs ys | _, Right_arrow :: ys -> memo ~xpolarity ~ypolarity i (succ j) xs ys | Right_arrow :: xs, _ -> memo ~xpolarity ~ypolarity (succ i) j xs ys | Product { length = a; _ } :: xs, Product { length = b; _ } :: ys | Argument { length = a; _ } :: xs, Argument { length = b; _ } :: ys -> - let l = abs (a - b) in - l + memo ~xpolarity ~ypolarity (succ i) (succ j) xs ys + let l = abs (a - b) in + l + memo ~xpolarity ~ypolarity (succ i) (succ j) xs ys | Product _ :: xs, ys -> 1 + memo ~xpolarity ~ypolarity (succ i) j xs ys | xs, Product _ :: ys -> 1 + memo ~xpolarity ~ypolarity i (succ j) xs ys | Tyname x :: xs', Tyname y :: ys' when P.equal xpolarity ypolarity -> ( - match Name_cost.distance x y with - | None -> skip_entry + memo ~xpolarity ~ypolarity i (succ j) xs ys' - | Some cost -> - cost + memo ~xpolarity ~ypolarity (succ i) (succ j) xs' ys') + match Name_cost.distance x y with + | None -> skip_entry + memo ~xpolarity ~ypolarity i (succ j) xs ys' + | Some cost -> cost + memo ~xpolarity ~ypolarity (succ i) (succ j) xs' ys' + ) | xs, Tyname _ :: ys -> - skip_entry + memo ~xpolarity ~ypolarity i (succ j) xs ys + skip_entry + memo ~xpolarity ~ypolarity i (succ j) xs ys | xs, Argument _ :: ys -> memo ~xpolarity ~ypolarity i (succ j) xs ys | _, (Wildcard | Tyvar _) :: _ -> max_distance in @@ -146,39 +146,39 @@ let replace_score best score = best := Int.min score !best let minimize = function | [] -> 0 | list -> - let used, arr, heuristics = init_heuristic list in - let best = ref 1000 and limit = ref 0 in - let len_a = Array.length arr in - let rec aux rem acc i = - let () = incr limit in - if !limit > max_distance then false - else if rem <= 0 then - let score = acc + (1000 * (len_a - i)) in - let () = replace_score best score in - true - else if i >= len_a then - let score = acc + (5 * rem) in - let () = replace_score best score in - true - else if acc + heuristics.(i) >= !best then true - else - let rec find = function - | [] -> true - | (cost, j) :: rest -> - let continue = - if used.(j) then true - else - let () = used.(j) <- true in - let continue = aux (pred rem) (acc + cost) (succ i) in - let () = used.(j) <- false in - continue - in - if continue then find rest else false - in - find arr.(i) - in - let _ = aux (Array.length used) 0 0 in - !best + let used, arr, heuristics = init_heuristic list in + let best = ref 1000 and limit = ref 0 in + let len_a = Array.length arr in + let rec aux rem acc i = + let () = incr limit in + if !limit > max_distance then false + else if rem <= 0 then + let score = acc + (1000 * (len_a - i)) in + let () = replace_score best score in + true + else if i >= len_a then + let score = acc + (5 * rem) in + let () = replace_score best score in + true + else if acc + heuristics.(i) >= !best then true + else + let rec find = function + | [] -> true + | (cost, j) :: rest -> + let continue = + if used.(j) then true + else + let () = used.(j) <- true in + let continue = aux (pred rem) (acc + cost) (succ i) in + let () = used.(j) <- false in + continue + in + if continue then find rest else false + in + find arr.(i) + in + let _ = aux (Array.length used) 0 0 in + !best let compute ~query ~entry = let query = make_path query in diff --git a/src/sherlodoc/type_distance.mli b/src/sherlodoc/type_distance.mli index d4bd0b3d8..f492d0495 100644 --- a/src/sherlodoc/type_distance.mli +++ b/src/sherlodoc/type_distance.mli @@ -28,6 +28,6 @@ (** Calculate an approximation of the distance between two types. *) -val compute : query:Type_expr.t -> entry:Type_expr.t -> int (** [compute a b] calculates an approximation of the distance between [query] and [entry]. *) +val compute : query:Type_expr.t -> entry:Type_expr.t -> int diff --git a/src/sherlodoc/type_expr.ml b/src/sherlodoc/type_expr.ml index b7322b163..d613a80da 100644 --- a/src/sherlodoc/type_expr.ml +++ b/src/sherlodoc/type_expr.ml @@ -78,15 +78,15 @@ and as_list acc = function | [] -> acc ^ unhandled | [ x ] -> acc ^ to_string x | x :: xs -> - let acc = acc ^ to_string x ^ ", " in - as_list acc xs + let acc = acc ^ to_string x ^ ", " in + as_list acc xs and as_tuple acc = function | [] -> acc ^ unhandled | [ x ] -> acc ^ with_parens x | x :: xs -> - let acc = acc ^ with_parens x ^ " * " in - as_tuple acc xs + let acc = acc ^ with_parens x ^ " * " in + as_tuple acc xs module SMap = Map.Make (String) @@ -106,25 +106,25 @@ let normalize_type_parameters ty = | Type_parsed.Unhandled -> (i, map, Unhandled) | Type_parsed.Wildcard -> (i, map, Wildcard) | Type_parsed.Arrow (a, b) -> - let i, map, a = aux i map a in - let i, map, b = aux i map b in - (i, map, Arrow (a, b)) + let i, map, a = aux i map a in + let i, map, b = aux i map b in + (i, map, Arrow (a, b)) | Type_parsed.Tycon (s, r) -> - let i, map, r = map_with_state aux i map r in - (i, map, Tycon (s, r)) + let i, map, r = map_with_state aux i map r in + (i, map, Tycon (s, r)) | Type_parsed.Tuple r -> - let i, map, r = map_with_state aux i map r in - (i, map, Tuple r) + let i, map, r = map_with_state aux i map r in + (i, map, Tuple r) | Type_parsed.Tyvar var -> - let i, map, value = - match SMap.find_opt var map with - | Some value -> (i, map, value) - | None -> - let i = succ i in - let map = SMap.add var i map in - (i, map, i) - in - (i, map, Tyvar value) + let i, map, value = + match SMap.find_opt var map with + | Some value -> (i, map, value) + | None -> + let i = succ i in + let map = SMap.add var i map in + (i, map, i) + in + (i, map, Tyvar value) in let _, _, normalized = aux ~-1 SMap.empty ty in normalized diff --git a/src/sherlodoc/type_expr.mli b/src/sherlodoc/type_expr.mli index ea3cb6382..413003897 100644 --- a/src/sherlodoc/type_expr.mli +++ b/src/sherlodoc/type_expr.mli @@ -43,15 +43,15 @@ type t = | Wildcard | Unhandled -val normalize_type_parameters : Type_parsed.t -> t (** [normalize_type_parameters ty] replace string based type variables to integer based type variables. *) +val normalize_type_parameters : Type_parsed.t -> t -val from_string : string -> t option (** Try deserializing a string into a typed expression. *) +val from_string : string -> t option -val to_string : t -> string (** Render a type to a string. *) +val to_string : t -> string -val equal : t -> t -> bool (** Equality between types *) +val equal : t -> t -> bool diff --git a/src/sherlodoc/type_parsed.mli b/src/sherlodoc/type_parsed.mli index f2a36136f..970796f66 100644 --- a/src/sherlodoc/type_parsed.mli +++ b/src/sherlodoc/type_parsed.mli @@ -37,8 +37,8 @@ type t = | Wildcard | Unhandled -val tuple : t list -> t (** Create a tuple using a rather naive heuristic: - If the list is empty, it produces a type [unit] - If the list contains only one element, that element is returned - Otherwise, a tuple is constructed. *) +val tuple : t list -> t diff --git a/src/sherlodoc/type_polarity.mli b/src/sherlodoc/type_polarity.mli index db282dbe6..99592b796 100644 --- a/src/sherlodoc/type_polarity.mli +++ b/src/sherlodoc/type_polarity.mli @@ -35,15 +35,15 @@ type t val positive : t val negative : t -val negate : t -> t (** [negate x] returns [positive] if [x] is [negative] and [negative] if [x] is [positive]. *) +val negate : t -> t -val equal : t -> t -> bool (** Equality between polarity sign. *) +val equal : t -> t -> bool -val compare : t -> t -> int (** A comparison that act that [negative < positive]. *) +val compare : t -> t -> int -val to_string : t -> string (** Simple printer for polarity sign. *) +val to_string : t -> string diff --git a/src/utils/marg.ml b/src/utils/marg.ml index 7046cf96a..2d4e3a130 100644 --- a/src/utils/marg.ml +++ b/src/utils/marg.ml @@ -26,11 +26,11 @@ let bool f = failwithf "expecting boolean (%s), got %S." "yes|y|Y|true|1 / no|n|N|false|0" str) -let int f = param "int" (fun str -> - match int_of_string_opt str with - | None -> failwithf "expecting integer got %S." str - | Some x -> f x - ) +let int f = + param "int" (fun str -> + match int_of_string_opt str with + | None -> failwithf "expecting integer got %S." str + | Some x -> f x) type docstring = string diff --git a/tests/test-units/sherldoc/name_cost_test.ml b/tests/test-units/sherldoc/name_cost_test.ml index 8320b2b1c..8d9befbb1 100644 --- a/tests/test-units/sherldoc/name_cost_test.ml +++ b/tests/test-units/sherldoc/name_cost_test.ml @@ -7,8 +7,7 @@ let test_distance_1 = and computed = List.map (Name_cost.distance "decode") - [ - "decode"; + [ "decode"; "decade"; "decede"; "decide"; @@ -16,7 +15,7 @@ let test_distance_1 = "bbcode"; "become"; "code"; - "derobe"; + "derobe" ] in check (list @@ option int) "should be equal" expected computed) @@ -110,8 +109,7 @@ let test_best_distance_3 = let cases = ( "name_cost", - [ - test_distance_1; + [ test_distance_1; test_distance_2; test_distance_3; test_distance_4; @@ -122,5 +120,5 @@ let cases = test_distance_substring_4; test_best_distance_1; test_best_distance_2; - test_best_distance_3; + test_best_distance_3 ] ) diff --git a/tests/test-units/sherldoc/query_test.ml b/tests/test-units/sherldoc/query_test.ml index 429dbf9d5..37be9f4e2 100644 --- a/tests/test-units/sherldoc/query_test.ml +++ b/tests/test-units/sherldoc/query_test.ml @@ -114,13 +114,12 @@ let test_distance_8 = let cases = ( "query-parser", - [ - test_distance_1; + [ test_distance_1; test_distance_2; test_distance_3; test_distance_4; test_distance_5; test_distance_6; test_distance_7; - test_distance_8; + test_distance_8 ] ) diff --git a/tests/test-units/sherldoc/sherlodoc_test.ml b/tests/test-units/sherldoc/sherlodoc_test.ml index a043d98ff..d58b10d9f 100644 --- a/tests/test-units/sherldoc/sherlodoc_test.ml +++ b/tests/test-units/sherldoc/sherlodoc_test.ml @@ -1,8 +1,7 @@ let () = Alcotest.run "merlin-lib.sherlodoc" - [ - Type_expr_test.cases; + [ Type_expr_test.cases; Name_cost_test.cases; Type_distance_test.cases; - Query_test.cases; + Query_test.cases ] diff --git a/tests/test-units/sherldoc/type_distance_test.ml b/tests/test-units/sherldoc/type_distance_test.ml index b8aabd391..2b4707092 100644 --- a/tests/test-units/sherldoc/type_distance_test.ml +++ b/tests/test-units/sherldoc/type_distance_test.ml @@ -15,8 +15,7 @@ let expected_distance query entry expected = let cases = ( "type_distance", - [ - expected_distance "int" "int" 0; + [ expected_distance "int" "int" 0; expected_distance "string" "string" 0; expected_distance "string -> int" "string -> int" 0; expected_distance "string -> int -> float" "string -> int -> float" 0; @@ -41,5 +40,5 @@ let cases = expected_distance "('a -> 'a) -> 'a list -> 'a list" "('a -> 'b) -> 'a list -> 'b list" 2; expected_distance "'a -> 'b option -> 'a option" - "'b option -> 'a -> 'a option" 3; + "'b option -> 'a -> 'a option" 3 ] ) diff --git a/tests/test-units/sherldoc/type_expr_test.ml b/tests/test-units/sherldoc/type_expr_test.ml index 0a5b7b18f..7034a802a 100644 --- a/tests/test-units/sherldoc/type_expr_test.ml +++ b/tests/test-units/sherldoc/type_expr_test.ml @@ -135,12 +135,11 @@ let test_long_poly_identifier_1 = let cases = ( "type_expr", - [ - test_parse_simple_type_1; + [ test_parse_simple_type_1; test_parse_simple_type_2; test_parse_simple_type_3; test_parse_simple_type_4; test_simple_isomorphismic_poly_function_1; test_poly_identifier_1; - test_long_poly_identifier_1; + test_long_poly_identifier_1 ] ) From 57b67b447103771b446e98ca5bdbad11a18199d2 Mon Sep 17 00:00:00 2001 From: xvw Date: Tue, 24 Sep 2024 16:44:11 +0200 Subject: [PATCH 21/24] Make final sort determinist --- src/analysis/type_search.ml | 6 ++- ...ch-by-type-comparison-to-polarity-search.t | 20 +++---- tests/test-dirs/search-by-type.t/run.t | 52 +++++++++---------- 3 files changed, 41 insertions(+), 37 deletions(-) diff --git a/src/analysis/type_search.ml b/src/analysis/type_search.ml index 9ab04e5f1..e8bb75ac0 100644 --- a/src/analysis/type_search.ml +++ b/src/analysis/type_search.ml @@ -84,7 +84,11 @@ let compare_result Query_protocol.{ cost = cost_a; name = a; doc = doc_a; _ } 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) + | 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 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 dc5aa5f88..0654dbb1f 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": "Int64.of_string_opt", - "type": "string -> int64 option" - } { "name": "Int32.of_string_opt", "type": "string -> int32 option" } + { + "name": "Int64.of_string_opt", + "type": "string -> int64 option" + } { "name": "Sys.getenv_opt", "type": "string -> string option" @@ -132,17 +132,17 @@ map). "name": "Seq.map", "type": "('a -> 'b) -> 'a Stdlib__Seq.t -> 'b Stdlib__Seq.t" } - { - "name": "List.filter_map", - "type": "('a -> 'b option) -> 'a list -> 'b list" - } { "name": "List.concat_map", "type": "('a -> 'b list) -> 'a list -> 'b list" } { - "name": "ListLabels.filter_map", - "type": "f:('a -> 'b option) -> 'a list -> 'b list" + "name": "List.filter_map", + "type": "('a -> 'b option) -> 'a list -> 'b list" + } + { + "name": "ListLabels.concat_map", + "type": "f:('a -> 'b list) -> 'a list -> 'b list" } diff --git a/tests/test-dirs/search-by-type.t/run.t b/tests/test-dirs/search-by-type.t/run.t index 849b3de60..06b4a4da4 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": null } { - "name": "Int64.of_string_opt", - "type": "string -> int64 option", + "name": "Int32.of_string_opt", + "type": "string -> int32 option", "cost": 2, "doc": null } { - "name": "Int32.of_string_opt", - "type": "string -> int32 option", + "name": "Int64.of_string_opt", + "type": "string -> int64 option", "cost": 2, "doc": null } @@ -109,20 +109,20 @@ "doc": null } { - "name": "List.filter_map", - "type": "('a -> 'b option) -> 'a list -> 'b list", + "name": "List.concat_map", + "type": "('a -> 'b list) -> 'a list -> 'b list", "cost": 10, "doc": null } { - "name": "List.concat_map", - "type": "('a -> 'b list) -> 'a list -> 'b list", + "name": "List.filter_map", + "type": "('a -> 'b option) -> 'a list -> 'b list", "cost": 10, "doc": null } { - "name": "ListLabels.filter_map", - "type": "f:('a -> 'b option) -> 'a list -> 'b list", + "name": "ListLabels.concat_map", + "type": "f:('a -> 'b list) -> 'a list -> 'b list", "cost": 10, "doc": null } @@ -234,34 +234,34 @@ { "file": "moreLabels.mli", "start": { - "line": 168, + "line": 318, "col": 2 }, "end": { - "line": 168, - "col": 55 + "line": 318, + "col": 52 }, - "name": "MoreLabels.Hashtbl.replace", - "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> key:'a -> data:'b -> unit", + "name": "MoreLabels.Hashtbl.add_seq", + "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> ('a * 'b) Seq.t -> unit", "cost": 48, "doc": null, - "constructible": "MoreLabels.Hashtbl.replace _ ~key:_ ~data:_" + "constructible": "MoreLabels.Hashtbl.add_seq _ _" }, { "file": "moreLabels.mli", "start": { - "line": 318, + "line": 168, "col": 2 }, "end": { - "line": 318, - "col": 52 + "line": 168, + "col": 55 }, - "name": "MoreLabels.Hashtbl.add_seq", - "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> ('a * 'b) Seq.t -> unit", + "name": "MoreLabels.Hashtbl.replace", + "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> key:'a -> data:'b -> unit", "cost": 48, "doc": null, - "constructible": "MoreLabels.Hashtbl.add_seq _ _" + "constructible": "MoreLabels.Hashtbl.replace _ ~key:_ ~data:_" }, { "file": "moreLabels.mli", @@ -316,14 +316,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": "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" } { - "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" } From 50e90862ec0e74fc9fb2506a53a9eb9376b237f0 Mon Sep 17 00:00:00 2001 From: xvw Date: Tue, 24 Sep 2024 17:34:32 +0200 Subject: [PATCH 22/24] Move search-test in a dedicated folder (to be discarded for Windows) --- tests/test-dirs/search/dune | 4 ++++ .../polarity-search-comparison-to-search-by-type.t | 0 .../search-by-type-comparison-to-polarity-search.t | 0 tests/test-dirs/{ => search}/search-by-type.t/context.ml | 0 tests/test-dirs/{ => search}/search-by-type.t/run.t | 0 5 files changed, 4 insertions(+) create mode 100644 tests/test-dirs/search/dune rename tests/test-dirs/{ => search}/polarity-search-comparison-to-search-by-type.t (100%) rename tests/test-dirs/{ => search}/search-by-type-comparison-to-polarity-search.t (100%) rename tests/test-dirs/{ => search}/search-by-type.t/context.ml (100%) rename tests/test-dirs/{ => search}/search-by-type.t/run.t (100%) diff --git a/tests/test-dirs/search/dune b/tests/test-dirs/search/dune new file mode 100644 index 000000000..94800b26f --- /dev/null +++ b/tests/test-dirs/search/dune @@ -0,0 +1,4 @@ +(cram + (applies_to :whole_subtree) + (enabled_if + (<> %{os_type} Win32))) diff --git a/tests/test-dirs/polarity-search-comparison-to-search-by-type.t b/tests/test-dirs/search/polarity-search-comparison-to-search-by-type.t similarity index 100% rename from tests/test-dirs/polarity-search-comparison-to-search-by-type.t rename to tests/test-dirs/search/polarity-search-comparison-to-search-by-type.t diff --git a/tests/test-dirs/search-by-type-comparison-to-polarity-search.t b/tests/test-dirs/search/search-by-type-comparison-to-polarity-search.t similarity index 100% rename from tests/test-dirs/search-by-type-comparison-to-polarity-search.t rename to tests/test-dirs/search/search-by-type-comparison-to-polarity-search.t diff --git a/tests/test-dirs/search-by-type.t/context.ml b/tests/test-dirs/search/search-by-type.t/context.ml similarity index 100% rename from tests/test-dirs/search-by-type.t/context.ml rename to tests/test-dirs/search/search-by-type.t/context.ml diff --git a/tests/test-dirs/search-by-type.t/run.t b/tests/test-dirs/search/search-by-type.t/run.t similarity index 100% rename from tests/test-dirs/search-by-type.t/run.t rename to tests/test-dirs/search/search-by-type.t/run.t From 0ce4c923db091aad34de3399ee48691dbfc6a81e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 25 Sep 2024 10:33:23 +0200 Subject: [PATCH 23/24] Printing types and fetching documentation is expensive. We only do it after the limit is enforced. --- src/analysis/polarity_search.ml | 47 +++++++++------------------------ src/analysis/type_search.ml | 40 ++++++++++++++-------------- src/analysis/type_search.mli | 20 +++++++------- src/frontend/query_commands.ml | 29 ++++++++++++-------- src/frontend/query_protocol.ml | 6 ++--- 5 files changed, 63 insertions(+), 79 deletions(-) diff --git a/src/analysis/polarity_search.ml b/src/analysis/polarity_search.ml index 2c7ada451..56d738392 100644 --- a/src/analysis/polarity_search.ml +++ b/src/analysis/polarity_search.ml @@ -145,40 +145,17 @@ let execute_query query env dirs = in List.fold_left dirs ~init:(direct None []) ~f:recurse -let execute_query_as_type_search ?(limit = 100) ~env ~query ~modules doc_ctx = - 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 name = Format.asprintf "%a" Printtyp.path path in - let doc = Type_search.get_doc doc_ctx env name in - 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 - 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 - modules - |> List.fold_left ~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 path = Printtyp.rewrite_double_underscore_paths env path in + let name = 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 diff --git a/src/analysis/type_search.ml b/src/analysis/type_search.ml index e8bb75ac0..ab78bb435 100644 --- a/src/analysis/type_search.ml +++ b/src/analysis/type_search.ml @@ -69,12 +69,9 @@ let doc_to_option = function | `Builtin doc | `Found doc -> Some doc | _ -> None -let get_doc doc_ctx env name = - match doc_ctx with - | None -> None - | Some (config, local_defs, comments, pos) -> - Locate.get_doc ~config ~env ~local_defs ~comments ~pos (`User_input name) - |> doc_to_option +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; _ } = @@ -92,7 +89,7 @@ let compare_result Query_protocol.{ cost = cost_a; name = a; doc = doc_a; _ } | _ -> c else c -let compute_value doc_ctx query env _ path desc acc = +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 @@ -101,25 +98,28 @@ let compute_value doc_ctx query env _ path desc acc = let cost = Query.distance_for query ~path:name typ in if cost >= 1000 then acc else - let doc = get_doc doc_ctx env name in + (* let doc = get_doc doc_ctx env name in *) + let doc = None in let loc = desc.Types.val_loc in - let typ = - Format.asprintf "%a" - (Type_utils.Printtyp.type_scheme env) - desc.Types.val_type - in + (* let typ = + Printtyp.wrap_printing_env env @@ fun () -> + Format.asprintf "%a" + (Type_utils.Printtyp.type_scheme env) + desc.Types.val_type + 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 doc_ctx query env lident acc = - Env.fold_values (compute_value doc_ctx query env) lident env acc +let compute_values query env lident acc = + Env.fold_values (compute_value query env) lident env acc -let values_from_module doc_ctx query env lident 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 doc_ctx query env (Some lident) acc in + let acc = compute_values query env (Some lident) acc in Env.fold_modules (fun name _ mdl acc -> match mdl.Types.md_type with @@ -131,12 +131,12 @@ let values_from_module doc_ctx query env lident acc = in aux acc lident -let run ?(limit = 100) ~env ~query ~modules doc_ctx = - let init = compute_values doc_ctx query env None [] in +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 doc_ctx query env lident acc) + values_from_module query env lident acc) |> List.sort ~cmp:compare_result |> List.take_n limit diff --git a/src/analysis/type_search.mli b/src/analysis/type_search.mli index a4dc9dd51..8c3bcae14 100644 --- a/src/analysis/type_search.mli +++ b/src/analysis/type_search.mli @@ -36,22 +36,22 @@ val run : env:Env.t -> query:Merlin_sherlodoc.Query.t -> modules:string list -> - (Mconfig.t * Mtyper.typedtree * (string * Location.t) list * Lexing.position) - option -> - Query_protocol.type_search_result list + unit -> + Types.type_expr Query_protocol.type_search_result list val get_doc : - (Mconfig.t - * Mtyper.typedtree - * (string * Warnings.loc) list - * Lexing.position) - option -> - Env.t -> + config:Mconfig.t -> + env:Env.t -> + local_defs:Mtyper.typedtree -> + comments:(string * Location.t) list -> + pos:Lexing.position -> string -> string option val make_constructible : string -> Types.type_expr -> string val compare_result : - Query_protocol.type_search_result -> Query_protocol.type_search_result -> int + _ 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 37d8c57ae..a65618e3b 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -469,24 +469,31 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function let env, _ = Mbrowse.leaf_node node in let config = Mpipeline.final_config pipeline in let modules = Mconfig.global_modules config in - let doc_ctx = - if with_doc then - let comments = Mpipeline.reader_comments pipeline in - let local_defs = Mtyper.get_typedtree typer in - Some (config, local_defs, comments, pos) - else None - in - begin + let verbosity = verbosity pipeline in + let results = match Type_search.classify_query query with | `By_type query -> let query = Merlin_sherlodoc.Query.from_string query in - Type_search.run ~limit ~env ~query ~modules doc_ctx + Type_search.run ~limit ~env ~query ~modules () | `Polarity query -> let query = Polarity_search.prepare_query env query in let modules = Polarity_search.directories ~global_modules:modules env in Polarity_search.execute_query_as_type_search ~limit ~env ~query ~modules - doc_ctx - end + () + in + List.map results ~f:(fun ({ name; typ; doc; _ } as v) -> + let typ = + Printtyp.wrap_printing_env ~verbosity env @@ fun () -> + Format.asprintf "%a" (Type_utils.Printtyp.type_scheme env) typ + in + let doc = + if not with_doc then doc + else + let comments = Mpipeline.reader_comments pipeline in + let local_defs = Mtyper.get_typedtree typer in + Type_search.get_doc ~config ~env ~local_defs ~comments ~pos name + in + { v with typ; doc }) | Refactor_open (mode, pos) -> let typer = Mpipeline.typer_result pipeline in let pos = Mpipeline.get_lexing_pos pipeline pos in diff --git a/src/frontend/query_protocol.ml b/src/frontend/query_protocol.ml index 0616a3feb..4ac5d9209 100644 --- a/src/frontend/query_protocol.ml +++ b/src/frontend/query_protocol.ml @@ -67,9 +67,9 @@ end type completions = Compl.t -type type_search_result = +type 'a type_search_result = { name : string; - typ : string; + typ : 'a; loc : Location_aux.t; doc : string option; cost : int; @@ -150,7 +150,7 @@ type _ t = | Polarity_search : string * Msource.position -> completions t | Type_search : string * Msource.position * int * bool - -> type_search_result list t + -> string type_search_result list t | Refactor_open : [ `Qualify | `Unqualify ] * Msource.position -> (string * Location.t) list t From dcfe1d66cca7113ea415571117bea3b2012e790c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= Date: Wed, 25 Sep 2024 10:45:01 +0200 Subject: [PATCH 24/24] Set printing env before printing value names. This might help with short-paths, we should introduce tests showing it. --- src/analysis/polarity_search.ml | 7 +++++-- src/analysis/type_search.ml | 14 +++++--------- 2 files changed, 10 insertions(+), 11 deletions(-) diff --git a/src/analysis/polarity_search.ml b/src/analysis/polarity_search.ml index 56d738392..bf3e124c9 100644 --- a/src/analysis/polarity_search.ml +++ b/src/analysis/polarity_search.ml @@ -150,8 +150,11 @@ let execute_query query env dirs = let execute_query_as_type_search ?(limit = 100) ~env ~query ~modules () = execute_query query env modules |> List.map ~f:(fun (cost, path, desc) -> - let path = Printtyp.rewrite_double_underscore_paths env path in - let name = Format.asprintf "%a" Printtyp.path path 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 doc = None in let loc = desc.Types.val_loc in let typ = desc.Types.val_type in diff --git a/src/analysis/type_search.ml b/src/analysis/type_search.ml index ab78bb435..48337219c 100644 --- a/src/analysis/type_search.ml +++ b/src/analysis/type_search.ml @@ -93,20 +93,16 @@ 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 path = Printtyp.rewrite_double_underscore_paths env path in - let name = Format.asprintf "%a" Printtyp.path path 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 = get_doc doc_ctx env name in *) let doc = None in let loc = desc.Types.val_loc in - (* let typ = - Printtyp.wrap_printing_env env @@ fun () -> - Format.asprintf "%a" - (Type_utils.Printtyp.type_scheme env) - desc.Types.val_type - in *) let typ = desc.Types.val_type in let constructible = make_constructible name d in Query_protocol.{ cost; name; typ; loc; doc; constructible } :: acc