diff --git a/.ocamlformat b/.ocamlformat index 2f1d4222b2..10492f340e 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/CHANGES.md b/CHANGES.md index 14581d1e97..b251a41402 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -9,10 +9,14 @@ unreleased - Implement new expand-node command for expanding PPX annotations (#1745) - Implement new inlay-hints command for adding hints on a sourcetree (#1812) - Add `signature-help` command (#1720) + - 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 4.16 =========== diff --git a/doc/dev/PROTOCOL.md b/doc/dev/PROTOCOL.md index 7d03d986f7..16fac57f0b 100644 --- a/doc/dev/PROTOCOL.md +++ b/doc/dev/PROTOCOL.md @@ -425,6 +425,35 @@ 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 -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. + +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` diff --git a/emacs/merlin.el b/emacs/merlin.el index cf5dd0089e..c736a28018 100644 --- a/emacs/merlin.el +++ b/emacs/merlin.el @@ -137,10 +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-favourite-caml-mode nil "The OCaml mode to use for the *merlin-types* buffer." :group 'merlin :type 'symbol) @@ -1094,51 +1090,70 @@ An ocaml atom is any string containing [a-z_0-9A-Z`.]." (cons (if bounds (car bounds) (point)) (point)))) -;;;;;;;;;;;;;;;;;;;;; -;; POLARITY SEARCH ;; -;;;;;;;;;;;;;;;;;;;;; -(defun merlin--search (query) - (merlin-call "search-by-polarity" - "-query" query - "-position" (merlin-unmake-point (point)))) +;;;;;;;;;;;; +;; SEARCH ;; +;;;;;;;;;;;; -(defun merlin--get-polarity-buff () - (get-buffer-create merlin-polarity-search-buffer-name)) +(defun merlin--search (query) + (merlin-call "search-by-type" + "-query" query + "-position" (merlin-unmake-point (point)))) -(defun merlin--render-polarity-result (name type) +(defun merlin--search-format-key (name type doc) (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))))) + (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) - (interactive "sSearch pattern: ") - (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))))) + "Search values by types or polarity" + (interactive "sSearch 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 ;; diff --git a/merlin-lib.opam b/merlin-lib.opam index 1a9eb26aa1..72270d1c42 100644 --- a/merlin-lib.opam +++ b/merlin-lib.opam @@ -13,6 +13,7 @@ depends: [ "ocaml" {>= "4.14" & < "4.15"} "dune" {>= "2.9.0"} "csexp" {>= "1.5.1"} + "alcotest" {with-test} "menhir" {dev & >= "20201216"} "menhirLib" {dev & >= "20201216"} "menhirSdk" {dev & >= "20201216"} diff --git a/src/analysis/dune b/src/analysis/dune index 1521f351e9..97924c241b 100644 --- a/src/analysis/dune +++ b/src/analysis/dune @@ -17,6 +17,7 @@ merlin_extend merlin_kernel merlin_utils + merlin_sherlodoc ocaml_parsing ocaml_preprocess query_protocol diff --git a/src/analysis/polarity_search.ml b/src/analysis/polarity_search.ml index 33d68cd7cf..159f224b8a 100644 --- a/src/analysis/polarity_search.ml +++ b/src/analysis/polarity_search.ml @@ -80,6 +80,21 @@ 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 = @@ -126,3 +141,21 @@ let execute_query query env dirs = acc in List.fold_left dirs ~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 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 + 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 new file mode 100644 index 0000000000..48337219ca --- /dev/null +++ b/src/analysis/type_search.ml @@ -0,0 +1,144 @@ +(* {{{ 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 + +let sherlodoc_type_of env 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 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 + 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 doc_to_option = function + | `Builtin doc | `Found doc -> Some doc + | _ -> None + +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; _ } = + 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 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 + +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 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 = None in + let loc = desc.Types.val_loc 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 query env lident acc = + Env.fold_values (compute_value query env) lident env 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 query 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 + aux acc lident + +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 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 diff --git a/src/analysis/type_search.mli b/src/analysis/type_search.mli new file mode 100644 index 0000000000..8c3bcae14a --- /dev/null +++ b/src/analysis/type_search.mli @@ -0,0 +1,57 @@ +(* {{{ 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. *) + +(** Compute the list of candidates from a query inside a given environment. *) +val run : + ?limit:int -> + env:Env.t -> + query:Merlin_sherlodoc.Query.t -> + modules:string list -> + unit -> + Types.type_expr Query_protocol.type_search_result list + +val get_doc : + 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 + +val classify_query : string -> [ `By_type of string | `Polarity of string ] diff --git a/src/commands/new_commands.ml b/src/commands/new_commands.ml index 02d23b99a3..836c3334f6 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 30e1e73914..ebd527fa17 100644 --- a/src/commands/query_json.ml +++ b/src/commands/query_json.ml @@ -178,6 +178,13 @@ 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, with_doc) -> + mk "type-search" + [ ("query", `String query); + ("position", mk_position pos); + ("limit", `Int limit); + ("with-doc", `Bool with_doc) + ] | Occurrences (`Ident_at pos, scope) -> mk "occurrences" [ ("kind", `String "identifiers"); @@ -372,6 +379,24 @@ 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; doc; constructible } -> + with_location ~with_file:true loc + [ ("name", `String name); + ("type", `String typ); + ("cost", `Int cost); + ( "doc", + match doc with + | Some x -> `String x + | None -> `Null ); + ("constructible", `String constructible) + ]) + 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 +406,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 92776fa4f2..ac51d30fbf 100644 --- a/src/frontend/dune +++ b/src/frontend/dune @@ -29,4 +29,5 @@ merlin_specific merlin_config merlin_analysis + merlin_sherlodoc query_protocol)) diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index 20cf3172dd..b7ea91f4fd 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -445,21 +445,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,6 +463,38 @@ 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, with_doc) -> + 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 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 () + | `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 + () + 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 911465d9e3..4ac5d92095 100644 --- a/src/frontend/query_protocol.ml +++ b/src/frontend/query_protocol.ml @@ -67,6 +67,15 @@ end type completions = Compl.t +type 'a type_search_result = + { name : string; + typ : 'a; + loc : Location_aux.t; + doc : string option; + cost : int; + constructible : string + } + type outline = item list and item = { outline_name : string; @@ -139,6 +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 * bool + -> string type_search_result list t | Refactor_open : [ `Qualify | `Unqualify ] * Msource.position -> (string * Location.t) list t diff --git a/src/sherlodoc/dune b/src/sherlodoc/dune new file mode 100644 index 0000000000..bb11c8c41c --- /dev/null +++ b/src/sherlodoc/dune @@ -0,0 +1,9 @@ +(library + (name merlin_sherlodoc) + (public_name merlin-lib.sherlodoc)) + +(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 0000000000..c69009cfce --- /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 0000000000..51a7b90b09 --- /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. *) + +(** [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 + +(** [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 + +(** [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 new file mode 100644 index 0000000000..8d81d50eae --- /dev/null +++ b/src/sherlodoc/query.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.mli b/src/sherlodoc/query.mli new file mode 100644 index 0000000000..2cd5cd3160 --- /dev/null +++ b/src/sherlodoc/query.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.. *) + +(** Describes a search on an identifier and a type. *) +type t = { words : string list; type_expr : Type_expr.t option } + +(** Converts a string into a search query. *) +val from_string : string -> t + +(** Inspect a query (mostly for debugging purpose). *) +val to_string : t -> string + +(** Equality between queries. *) +val equal : t -> t -> bool + +(** [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 new file mode 100644 index 0000000000..7a3481dd13 --- /dev/null +++ b/src/sherlodoc/type_distance.ml @@ -0,0 +1,188 @@ +(* {{{ 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 + 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) [] + 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 0000000000..f492d0495e --- /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. *) + +(** [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 new file mode 100644 index 0000000000..d613a80da8 --- /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 0000000000..4130038974 --- /dev/null +++ b/src/sherlodoc/type_expr.mli @@ -0,0 +1,57 @@ +(* {{{ 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 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]. *) +type t = + | Arrow of t * t + | Tycon of string * t list + | Tuple of t list + | Tyvar of int + | Wildcard + | Unhandled + +(** [normalize_type_parameters ty] replace string based type variables to + integer based type variables. *) +val normalize_type_parameters : Type_parsed.t -> t + +(** Try deserializing a string into a typed expression. *) +val from_string : string -> t option + +(** Render a type to a string. *) +val to_string : t -> string + +(** Equality between types *) +val equal : t -> t -> bool diff --git a/src/sherlodoc/type_lexer.mll b/src/sherlodoc/type_lexer.mll new file mode 100644 index 0000000000..b1c798f22b --- /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 0000000000..c7166998b6 --- /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 0000000000..970796f66a --- /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 + +(** 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_parser.mly b/src/sherlodoc/type_parser.mly new file mode 100644 index 0000000000..a3c4a6bc72 --- /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 0000000000..541cbebc33 --- /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 0000000000..99592b796f --- /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 + +(** [negate x] returns [positive] if [x] is [negative] and [negative] if [x] is + [positive]. *) +val negate : t -> t + +(** Equality between polarity sign. *) +val equal : t -> t -> bool + +(** A comparison that act that [negative < positive]. *) +val compare : t -> t -> int + +(** Simple printer for polarity sign. *) +val to_string : t -> string diff --git a/src/utils/marg.ml b/src/utils/marg.ml index 58ab0ad394..2d4e3a1303 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 f867199694..1aba9a1ac7 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/dune b/tests/test-dirs/search/dune new file mode 100644 index 0000000000..94800b26f0 --- /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/search/polarity-search-comparison-to-search-by-type.t b/tests/test-dirs/search/polarity-search-comparison-to-search-by-type.t new file mode 100644 index 0000000000..896bb5486f --- /dev/null +++ b/tests/test-dirs/search/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": "Dynlink.unsafe_get_global_value", + "desc": "bytecode_or_asm_symbol:string -> Obj.t option" + } + { + "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" + } + +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/search-by-type-comparison-to-polarity-search.t b/tests/test-dirs/search/search-by-type-comparison-to-polarity-search.t new file mode 100644 index 0000000000..d59fc66539 --- /dev/null +++ b/tests/test-dirs/search/search-by-type-comparison-to-polarity-search.t @@ -0,0 +1,242 @@ + $ 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": "Pervasives.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": "Sys.getenv_opt", + "type": "string -> string 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" + } + +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": "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" + } + +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": "List.map", + "type": "('a -> 'b) -> 'a list -> 'b list" + } + { + "name": "List.rev_map", + "type": "('a -> 'b) -> 'a list -> 'b list" + } + { + "name": "ListLabels.map", + "type": "f:('a -> 'b) -> 'a list -> 'b list" + } + { + "name": "ListLabels.rev_map", + "type": "f:('a -> 'b) -> 'a list -> 'b list" + } + { + "name": "List.mapi", + "type": "(int -> 'a -> 'b) -> 'a list -> 'b list" + } + { + "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" + } + { + "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" + } + + +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" + } diff --git a/tests/test-dirs/search/search-by-type.t/context.ml b/tests/test-dirs/search/search-by-type.t/context.ml new file mode 100644 index 0000000000..306831a004 --- /dev/null +++ b/tests/test-dirs/search/search-by-type.t/context.ml @@ -0,0 +1 @@ +let () = () diff --git a/tests/test-dirs/search/search-by-type.t/run.t b/tests/test-dirs/search/search-by-type.t/run.t new file mode 100644 index 0000000000..3f8f2b1e5e --- /dev/null +++ b/tests/test-dirs/search/search-by-type.t/run.t @@ -0,0 +1,365 @@ + $ $MERLIN single search-by-type -filename ./context.ml \ + > -position 5:25 -limit 10 -query "string -> int option" | + > tr '\n' ' ' | jq '.value[] | {name,type,cost,doc}' + { + "name": "int_of_string_opt", + "type": "string -> int option", + "cost": 0, + "doc": null + } + { + "name": "int_of_string_opt", + "type": "string -> int option", + "cost": 0, + "doc": null + } + { + "name": "Pervasives.int_of_string_opt", + "type": "string -> int option", + "cost": 0, + "doc": null + } + { + "name": "Int32.of_string_opt", + "type": "string -> int32 option", + "cost": 2, + "doc": null + } + { + "name": "Int64.of_string_opt", + "type": "string -> int64 option", + "cost": 2, + "doc": null + } + { + "name": "Sys.getenv_opt", + "type": "string -> string option", + "cost": 4, + "doc": null + } + { + "name": "bool_of_string_opt", + "type": "string -> bool option", + "cost": 4, + "doc": null + } + { + "name": "bool_of_string_opt", + "type": "string -> bool option", + "cost": 4, + "doc": null + } + { + "name": "Float.of_string_opt", + "type": "string -> float option", + "cost": 4, + "doc": null + } + { + "name": "float_of_string_opt", + "type": "string -> float option", + "cost": 4, + "doc": null + } + + + $ $MERLIN single search-by-type -filename ./context.ml \ + > -position 5:25 -limit 10 -query "('a -> 'b) -> 'a list -> 'b list" | + > tr '\n' ' ' | jq '.value[] | {name,type,cost,doc}' + { + "name": "List.map", + "type": "('a -> 'b) -> 'a list -> 'b list", + "cost": 0, + "doc": null + } + { + "name": "List.rev_map", + "type": "('a -> 'b) -> 'a list -> 'b list", + "cost": 0, + "doc": null + } + { + "name": "ListLabels.map", + "type": "f:('a -> 'b) -> 'a list -> 'b list", + "cost": 0, + "doc": null + } + { + "name": "ListLabels.rev_map", + "type": "f:('a -> 'b) -> 'a list -> 'b list", + "cost": 0, + "doc": null + } + { + "name": "List.mapi", + "type": "(int -> 'a -> 'b) -> 'a list -> 'b list", + "cost": 5, + "doc": null + } + { + "name": "ListLabels.mapi", + "type": "f:(int -> 'a -> 'b) -> 'a list -> 'b list", + "cost": 5, + "doc": null + } + { + "name": "Seq.map", + "type": "('a -> 'b) -> 'a Stdlib__Seq.t -> 'b Stdlib__Seq.t", + "cost": 10, + "doc": null + } + { + "name": "List.concat_map", + "type": "('a -> 'b list) -> 'a list -> 'b list", + "cost": 10, + "doc": null + } + { + "name": "List.filter_map", + "type": "('a -> 'b option) -> 'a list -> 'b list", + "cost": 10, + "doc": null + } + { + "name": "ListLabels.concat_map", + "type": "f:('a -> 'b list) -> 'a list -> 'b list", + "cost": 10, + "doc": null + } + + $ $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": 82, + "col": 0 + }, + "end": { + "line": 82, + "col": 40 + }, + "name": "Hashtbl.add", + "type": "('a, 'b) Stdlib__Hashtbl.t -> 'a -> 'b -> unit", + "cost": 1, + "doc": null, + "constructible": "Hashtbl.add _ _ _" + }, + { + "file": "hashtbl.mli", + "start": { + "line": 113, + "col": 0 + }, + "end": { + "line": 113, + "col": 44 + }, + "name": "Hashtbl.replace", + "type": "('a, 'b) Stdlib__Hashtbl.t -> 'a -> 'b -> unit", + "cost": 2, + "doc": null, + "constructible": "Hashtbl.replace _ _ _" + }, + { + "file": "hashtbl.mli", + "start": { + "line": 262, + "col": 0 + }, + "end": { + "line": 262, + "col": 50 + }, + "name": "Hashtbl.add_seq", + "type": "('a, 'b) Stdlib__Hashtbl.t -> ('a * 'b) Seq.t -> unit", + "cost": 24, + "doc": null, + "constructible": "Hashtbl.add_seq _ _" + }, + { + "file": "hashtbl.mli", + "start": { + "line": 266, + "col": 0 + }, + "end": { + "line": 266, + "col": 54 + }, + "name": "Hashtbl.replace_seq", + "type": "('a, 'b) Stdlib__Hashtbl.t -> ('a * 'b) Seq.t -> unit", + "cost": 25, + "doc": null, + "constructible": "Hashtbl.replace_seq _ _" + }, + { + "file": "either.mli", + "start": { + "line": 86, + "col": 0 + }, + "end": { + "line": 87, + "col": 73 + }, + "name": "Either.map", + "type": "left:('a1 -> 'a2) -> + right:('b1 -> 'b2) -> + ('a1, 'b1) Stdlib__Either.t -> ('a2, 'b2) Stdlib__Either.t", + "cost": 44, + "doc": null, + "constructible": "Either.map ~left:_ ~right:_ _" + }, + { + "file": "moreLabels.mli", + "start": { + "line": 99, + "col": 2 + }, + "end": { + "line": 99, + "col": 51 + }, + "name": "MoreLabels.Hashtbl.add", + "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> key:'a -> data:'b -> unit", + "cost": 47, + "doc": null, + "constructible": "MoreLabels.Hashtbl.add _ ~key:_ ~data:_" + }, + { + "file": "moreLabels.mli", + "start": { + "line": 279, + "col": 2 + }, + "end": { + "line": 279, + "col": 52 + }, + "name": "MoreLabels.Hashtbl.add_seq", + "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> ('a * 'b) Seq.t -> unit", + "cost": 48, + "doc": null, + "constructible": "MoreLabels.Hashtbl.add_seq _ _" + }, + { + "file": "moreLabels.mli", + "start": { + "line": 130, + "col": 2 + }, + "end": { + "line": 130, + "col": 55 + }, + "name": "MoreLabels.Hashtbl.replace", + "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> key:'a -> data:'b -> unit", + "cost": 48, + "doc": null, + "constructible": "MoreLabels.Hashtbl.replace _ ~key:_ ~data:_" + }, + { + "file": "moreLabels.mli", + "start": { + "line": 283, + "col": 2 + }, + "end": { + "line": 283, + "col": 56 + }, + "name": "MoreLabels.Hashtbl.replace_seq", + "type": "('a, 'b) Stdlib__MoreLabels.Hashtbl.t -> ('a * 'b) Seq.t -> unit", + "cost": 49, + "doc": null, + "constructible": "MoreLabels.Hashtbl.replace_seq _ _" + }, + { + "file": "ephemeron.mli", + "start": { + "line": 388, + "col": 2 + }, + "end": { + "line": 388, + "col": 55 + }, + "name": "Ephemeron.K2.query", + "type": "('k1, 'k2, 'd) Stdlib__Ephemeron.K2.t -> 'k1 -> 'k2 -> 'd option", + "cost": 53, + "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": "Pervasives.int_of_string_opt", + "type": "string -> int option", + "cost": 0, + "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" + } + { + "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", + "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" + } diff --git a/tests/test-units/sherldoc/dune b/tests/test-units/sherldoc/dune new file mode 100644 index 0000000000..f84c9d6d2c --- /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 0000000000..8d9befbb15 --- /dev/null +++ b/tests/test-units/sherldoc/name_cost_test.ml @@ -0,0 +1,124 @@ +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 0000000000..bf105b099b --- /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_test.ml b/tests/test-units/sherldoc/query_test.ml new file mode 100644 index 0000000000..37be9f4e2b --- /dev/null +++ b/tests/test-units/sherldoc/query_test.ml @@ -0,0 +1,125 @@ +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.( + 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.( + 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.( + 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.( + 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.( + 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.( + 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.( + 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.( + 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_test.mli b/tests/test-units/sherldoc/query_test.mli new file mode 100644 index 0000000000..bf105b099b --- /dev/null +++ b/tests/test-units/sherldoc/query_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 0000000000..d58b10d9f2 --- /dev/null +++ b/tests/test-units/sherldoc/sherlodoc_test.ml @@ -0,0 +1,7 @@ +let () = + Alcotest.run "merlin-lib.sherlodoc" + [ Type_expr_test.cases; + Name_cost_test.cases; + Type_distance_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 new file mode 100644 index 0000000000..2b47070929 --- /dev/null +++ b/tests/test-units/sherldoc/type_distance_test.ml @@ -0,0 +1,44 @@ +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 0000000000..bf105b099b --- /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 0000000000..7034a802a6 --- /dev/null +++ b/tests/test-units/sherldoc/type_expr_test.ml @@ -0,0 +1,145 @@ +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 0000000000..bf105b099b --- /dev/null +++ b/tests/test-units/sherldoc/type_expr_test.mli @@ -0,0 +1 @@ +val cases : string * unit Alcotest.test_case list