From 3419ac6fe8392647c6c36db52312a2e0a3a90507 Mon Sep 17 00:00:00 2001 From: Rafal Gwozdzinski Date: Thu, 4 Jan 2024 08:43:05 +0100 Subject: [PATCH] Signature Help --- CHANGES.md | 1 + src/analysis/signature_help.ml | 259 +++++++++++++++++++ src/analysis/signature_help.mli | 25 ++ src/frontend/ocamlmerlin/new/new_commands.ml | 14 + src/frontend/ocamlmerlin/query_json.ml | 21 ++ src/frontend/query_commands.ml | 23 ++ src/frontend/query_protocol.ml | 15 ++ tests/test-dirs/signature-help.t | 240 +++++++++++++++++ 8 files changed, 598 insertions(+) create mode 100644 src/analysis/signature_help.ml create mode 100644 src/analysis/signature_help.mli create mode 100644 tests/test-dirs/signature-help.t diff --git a/CHANGES.md b/CHANGES.md index 901ca0b62..a23c9aa56 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -22,6 +22,7 @@ Thu Feb 22 14:00:42 CET 2024 - Jump to `module-type` (#1728, partially fixes #1656) - Exposes stable functions for configuration handling and pattern variable destruction. (#1730) + - Add `signature-help` command (#1720) + editor modes - vim: load merlin under the ocamlinterface and ocamllex filetypes (#1340) - Fix merlinpp not using binary file open (#1725, fixes #1724) diff --git a/src/analysis/signature_help.ml b/src/analysis/signature_help.ml new file mode 100644 index 000000000..898cdd6dd --- /dev/null +++ b/src/analysis/signature_help.ml @@ -0,0 +1,259 @@ +open Std + +type parameter_info = + { label : Asttypes.arg_label + ; param_start : int + ; param_end : int + ; argument : Typedtree.expression option + } + +type application_signature = + { function_name : string option + ; function_position : Msource.position + ; signature : string + ; parameters : parameter_info list + ; active_param : int option + } + +(* extract a properly parenthesized identifier from (expression_desc (Texp_ident + (Longident))) *) +let extract_ident (exp_desc : Typedtree.expression_desc) = + let rec longident ppf : Longident.t -> unit = function + | Lident s -> Format.fprintf ppf "%s" (Misc_utils.parenthesize_name s) + | Ldot (p, s) -> + Format.fprintf ppf "%a.%s" longident p (Misc_utils.parenthesize_name s) + | Lapply (p1, p2) -> Format.fprintf ppf "%a(%a)" longident p1 longident p2 + in + match exp_desc with + | Texp_ident (_, { txt = li; _ }, _) -> + let ppf, to_string = Format.to_string () in + longident ppf li; + Some (to_string ()) + | _ -> None + +(* Type variables shared across arguments should all be printed with the same + name. [Printtyp.type_scheme] ensure that a name is unique within a given + type, but not across different invocations. [reset] followed by calls to + [mark_loops] and [type_sch] provide that *) +let pp_type env ppf ty = + let module Printtyp = Type_utils.Printtyp in + Printtyp.wrap_printing_env env ~verbosity:(Lvl 0) (fun () -> + Printtyp.shared_type_scheme ppf ty) + +(* surround function types in parentheses *) +let pp_parameter_type env ppf ty = + match Types.get_desc ty with + | Tarrow _ -> Format.fprintf ppf "(%a)" (pp_type env) ty + | _ -> pp_type env ppf ty + +(* print parameter labels and types *) +let pp_parameter env label ppf ty = + match (label : Asttypes.arg_label) with + | Nolabel -> pp_parameter_type env ppf ty + | Labelled l -> Format.fprintf ppf "%s:%a" l (pp_parameter_type env) ty + | Optional l -> + (* unwrap option for optional labels the same way as + [Raw_compat.labels_of_application] *) + let unwrap_option ty = + match Types.get_desc ty with + | Types.Tconstr (path, [ ty ], _) when Path.same path Predef.path_option + -> ty + | _ -> ty + in + Format.fprintf ppf "?%s:%a" l (pp_parameter_type env) (unwrap_option ty) + +(* record buffer offsets to be able to underline parameter types *) +let print_parameter_offset ?arg:argument ppf buffer env label ty = + let param_start = Buffer.length buffer in + Format.fprintf ppf "%a%!" (pp_parameter env label) ty; + let param_end = Buffer.length buffer in + Format.pp_print_string ppf " -> "; + Format.pp_print_flush ppf (); + { label; param_start; param_end; argument } + +let separate_function_signature ~args (e : Typedtree.expression) = + Type_utils.Printtyp.reset (); + let buffer = Buffer.create 16 in + let ppf = Format.formatter_of_buffer buffer in + let rec separate ?(i = 0) ?(parameters = []) args ty = + match (args, Types.get_desc ty) with + | (_l, arg) :: args, Tarrow (label, ty1, ty2, _) -> + let parameter = + print_parameter_offset ppf buffer e.exp_env label ty1 ?arg + in + separate args ty2 ~i:(succ i) ~parameters:(parameter :: parameters) + | [], Tarrow (label, ty1, ty2, _) -> + let parameter = print_parameter_offset ppf buffer e.exp_env label ty1 in + separate args ty2 ~i:(succ i) ~parameters:(parameter :: parameters) + (* end of function type, print remaining type without recording offsets *) + | _ -> + Format.fprintf ppf "%a%!" (pp_type e.exp_env) ty; + { function_name = extract_ident e.exp_desc + ; function_position = `Offset e.exp_loc.loc_end.pos_cnum + ; signature = Buffer.contents buffer + ; parameters = List.rev parameters + ; active_param = None + } + in + separate args e.exp_type + +let active_parameter_by_arg ~arg params = + let find_by_arg = function + | { argument = Some a; _ } when a == arg -> true + | _ -> false + in + try Some (List.index params ~f:find_by_arg) with Not_found -> None + +let active_parameter_by_prefix ~prefix params = + let common = function + | Asttypes.Nolabel -> Some 0 + | l + when String.is_prefixed ~by:"~" prefix + || String.is_prefixed ~by:"?" prefix -> + Some (String.common_prefix_len (Btype.prefixed_label_name l) prefix) + | _ -> None + in + + let rec find_by_prefix ?(i = 0) ?longest_len ?longest_i = function + | [] -> longest_i + | p :: ps -> ( + match (common p.label, longest_len) with + | Some common_len, Some longest_len when common_len > longest_len -> + find_by_prefix ps ~i:(succ i) ~longest_len:common_len ~longest_i:i + | Some common_len, None -> + find_by_prefix ps ~i:(succ i) ~longest_len:common_len ~longest_i:i + | _ -> find_by_prefix ps ~i:(succ i) ?longest_len ?longest_i) + in + find_by_prefix params + +let is_arrow t = + match Types.get_desc t with + | Tarrow _ -> true + | _ -> false + +let application_signature ~prefix = function + (* provide signature information for applied functions *) + | (_, Browse_raw.Expression arg) + :: ( _ + , Expression { exp_desc = Texp_apply (({ exp_type; _ } as e), args); _ } + ) + :: _ + when is_arrow exp_type -> + let result = separate_function_signature e ~args in + let active_param = active_parameter_by_arg ~arg result.parameters in + let active_param = + match active_param with + | Some _ as ap -> ap + | None -> active_parameter_by_prefix ~prefix result.parameters + in + Some { result with active_param } + (* provide signature information directly after an unapplied function-type + value *) + | (_, Expression ({ exp_type; _ } as e)) :: _ when is_arrow exp_type -> + let result = separate_function_signature e ~args:[] in + let active_param = active_parameter_by_prefix ~prefix result.parameters in + Some { result with active_param } + | _ -> None + +module String = struct + include String + let rfindi = + let rec loop s ~f i = + if i < 0 then None + else if f (String.unsafe_get s i) then Some i + else loop s ~f (i - 1) + in + fun ?from s ~f -> + let from = + let len = String.length s in + match from with + | None -> len - 1 + | Some i -> + if i > len - 1 then failwith "rfindi: invalid from" + else i + in + loop s ~f from + + let rec check_prefix s ~prefix len i = + i = len || (s.[i] = prefix.[i] && check_prefix s ~prefix len (i + 1)) + + let lsplit2 s ~on = + match String.index_opt s on with + | None -> None + | Some i -> + Some (sub s ~pos:0 ~len:i, sub s ~pos:(i + 1) ~len:(length s - i - 1)) + + let is_prefix s ~prefix = + let len = length s in + let prefix_len = length prefix in + len >= prefix_len && check_prefix s ~prefix prefix_len 0 + end + +(** @see reference *) +let prefix_of_position ~short_path source position = + match Msource.text source with + | "" -> "" + | text -> + let from = + let (`Offset index) = Msource.get_offset source position in + min (String.length text - 1) (index - 1) + in + let pos = + let should_terminate = ref false in + let has_seen_dot = ref false in + let is_prefix_char c = + if !should_terminate then false + else + match c with + | 'a' .. 'z' + | 'A' .. 'Z' + | '0' .. '9' + | '\'' + | '_' + (* Infix function characters *) + | '$' + | '&' + | '*' + | '+' + | '-' + | '/' + | '=' + | '>' + | '@' + | '^' + | '!' + | '?' + | '%' + | '<' + | ':' + | '~' + | '#' -> true + | '`' -> + if !has_seen_dot then false + else ( + should_terminate := true; + true) + | '.' -> + has_seen_dot := true; + not short_path + | _ -> false + in + String.rfindi text ~from ~f:(fun c -> not (is_prefix_char c)) + in + let pos = + match pos with + | None -> 0 + | Some pos -> pos + 1 + in + let len = from - pos + 1 in + let reconstructed_prefix = String.sub text ~pos ~len in + (* if we reconstructed [~f:ignore] or [?f:ignore], we should take only + [ignore], so: *) + if + String.is_prefix reconstructed_prefix ~prefix:"~" + || String.is_prefix reconstructed_prefix ~prefix:"?" + then + match String.lsplit2 reconstructed_prefix ~on:':' with + | Some (_, s) -> s + | None -> reconstructed_prefix + else reconstructed_prefix diff --git a/src/analysis/signature_help.mli b/src/analysis/signature_help.mli new file mode 100644 index 000000000..3fb293fe8 --- /dev/null +++ b/src/analysis/signature_help.mli @@ -0,0 +1,25 @@ +type parameter_info = + { label : Asttypes.arg_label + ; param_start : int + ; param_end : int + ; argument : Typedtree.expression option + } + +type application_signature = + { function_name : string option + ; function_position : Msource.position + ; signature : string + ; parameters : parameter_info list + ; active_param : int option + } + +val application_signature : + prefix:string + -> Mbrowse.t + -> application_signature option + +val prefix_of_position : + short_path: bool + -> Msource.t + -> Msource.position + -> string diff --git a/src/frontend/ocamlmerlin/new/new_commands.ml b/src/frontend/ocamlmerlin/new/new_commands.ml index a1b753dd7..32137af67 100644 --- a/src/frontend/ocamlmerlin/new/new_commands.ml +++ b/src/frontend/ocamlmerlin/new/new_commands.ml @@ -665,6 +665,20 @@ The return value has the shape: ] end ; + command "signature-help" + ~doc:"Returns LSP Signature Help response" + ~spec: [ + arg "-position" " Position of Signature Help request" + (marg_position (fun pos (expr,_pos) -> (expr,pos))); + ] + ~default:("",`None) + begin fun buffer (_,pos) -> + match pos with + | `None -> failwith "-position is mandatory" + | #Msource.position as pos -> + run buffer (Query_protocol.Signature_help pos) + end + ; (* Used only for testing *) command "dump" diff --git a/src/frontend/ocamlmerlin/query_json.ml b/src/frontend/ocamlmerlin/query_json.ml index 69515bc1f..471713101 100644 --- a/src/frontend/ocamlmerlin/query_json.ml +++ b/src/frontend/ocamlmerlin/query_json.ml @@ -216,6 +216,10 @@ let dump (type a) : a t -> json = | `Unqualify -> "unqualify"); "position", mk_position pos; ] + | Signature_help pos -> + mk "signature-help" [ + "position", mk_position pos + ] | Version -> mk "version" [] let string_of_completion_kind = function @@ -349,6 +353,22 @@ let json_of_locate resp = | `Found (Some file,pos) -> `Assoc ["file",`String file; "pos", Lexing.json_of_position pos] +let json_of_signature_help resp = + let param { label_start; label_end } = + `Assoc ["label", `List [`Int label_start; `Int label_end]] in + match resp with + | None -> `Assoc [] + | Some { label; parameters; active_param; active_signature } -> + let signature = + `Assoc + ["label", `String label; + "parameters", `List (List.map ~f:param parameters);] in + `Assoc + ["signatures", `List [signature]; + "activeParameter", `Int active_param; + "activeSignature", `Int active_signature; + ] + let json_of_response (type a) (query : a t) (response : a) : json = match query, response with | Type_expr _, str -> `String str @@ -438,5 +458,6 @@ let json_of_response (type a) (query : a t) (response : a) : json = let with_file = scope = `Project in `List (List.map locations ~f:(fun loc -> with_location ~with_file loc [])) + | Signature_help _, s -> json_of_signature_help s | Version, version -> `String version diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml index ce64da921..05ea7818d 100644 --- a/src/frontend/query_commands.ml +++ b/src/frontend/query_commands.ml @@ -848,6 +848,29 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = let cmp l1 l2 = Lexing.compare_pos (loc_start l1) (loc_start l2) in List.sort ~cmp locs + | Signature_help pos -> + let typer = Mpipeline.typer_result pipeline in + let poss = Mpipeline.get_lexing_pos pipeline pos in + let node = Mtyper.node_at typer poss in + let source = Mpipeline.input_source pipeline in + let prefix = Signature_help.prefix_of_position ~short_path:true source pos in + let application_signature = Signature_help.application_signature ~prefix node in + let param offset (p: Signature_help.parameter_info) = + { label_start = offset + p.param_start; label_end = offset + p.param_end} in + (match application_signature with + | Some s -> + let prefix = + let fun_name = + Option.value ~default:"_" s.function_name + in + sprintf "%s : " fun_name in + Some { label = prefix ^ s.signature; + parameters = List.map ~f:(param (String.length prefix)) s.parameters; + active_param = Option.value ~default:0 s.active_param; + active_signature = 0; + } + | None -> None) + | Version -> Printf.sprintf "The Merlin toolkit version %s, for Ocaml %s\n" Merlin_config.version Sys.ocaml_version; diff --git a/src/frontend/query_protocol.ml b/src/frontend/query_protocol.ml index cd8871e47..207e829b0 100644 --- a/src/frontend/query_protocol.ml +++ b/src/frontend/query_protocol.ml @@ -103,6 +103,18 @@ type syntax_doc_result = documentation : string } +type signature_help_param = { + label_start : int; + label_end : int; +} + +type signature_help = { + label : string; + parameters : signature_help_param list; + active_param : int; + active_signature: int; +} + type is_tail_position = [`No | `Tail_position | `Tail_call] type _ _bool = bool @@ -208,5 +220,8 @@ type _ t = | Occurrences(* *) : [`Ident_at of Msource.position] * [`Project | `Buffer] -> Location.t list t + | Signature_help + : Msource.position + -> signature_help option t | Version : string t diff --git a/tests/test-dirs/signature-help.t b/tests/test-dirs/signature-help.t new file mode 100644 index 000000000..f59e9cf12 --- /dev/null +++ b/tests/test-dirs/signature-help.t @@ -0,0 +1,240 @@ +It can provide signature help after a function-type value. + + $ $MERLIN single signature-help -position 2:11 < let map = ListLabels.map + > let _ = map + > EOF + { + "class": "return", + "value": { + "signatures": [ + { + "label": "map : f:('a -> 'b) -> 'a list -> 'b list", + "parameters": [ + { + "label": [ + 6, + 18 + ] + }, + { + "label": [ + 22, + 29 + ] + } + ] + } + ], + "activeParameter": 1, + "activeSignature": 0 + }, + "notifications": [] + } + +It can provide signature help for an operator. + + $ $MERLIN single signature-help -position 2:13 < let (+) = (+) + > let _ = 1 + 2 + > EOF + { + "class": "return", + "value": { + "signatures": [ + { + "label": "(+) : int -> int -> int", + "parameters": [ + { + "label": [ + 6, + 9 + ] + }, + { + "label": [ + 13, + 16 + ] + } + ] + } + ], + "activeParameter": 1, + "activeSignature": 0 + }, + "notifications": [] + } + +It can provide signature help for an anonymous function. + + $ $MERLIN single signature-help -position 1:26 < let _ = (fun x -> x + 1) + > EOF + { + "class": "return", + "value": { + "signatures": [ + { + "label": "_ : int -> int", + "parameters": [ + { + "label": [ + 4, + 7 + ] + } + ] + } + ], + "activeParameter": 0, + "activeSignature": 0 + }, + "notifications": [] + } + +It can make the non-labelled parameter active. + + $ $MERLIN single signature-help -position 2:14 < let map = ListLabels.map + > let _ = map [] + > EOF + { + "class": "return", + "value": { + "signatures": [ + { + "label": "map : f:('a -> 'b) -> 'a list -> 'b list", + "parameters": [ + { + "label": [ + 6, + 18 + ] + }, + { + "label": [ + 22, + 29 + ] + } + ] + } + ], + "activeParameter": 1, + "activeSignature": 0 + }, + "notifications": [] + } + +It can make the labelled parameter active. + $ $MERLIN single signature-help -position 2:14 < let map = ListLabels.map + > let _ = map ~f:Int.abs + > EOF + { + "class": "return", + "value": { + "signatures": [ + { + "label": "map : f:(int -> int) -> int list -> int list", + "parameters": [ + { + "label": [ + 6, + 20 + ] + }, + { + "label": [ + 24, + 32 + ] + } + ] + } + ], + "activeParameter": 0, + "activeSignature": 0 + }, + "notifications": [] + } + +It can make a labelled parameter active by prefix. + + $ $MERLIN single signature-help -position 2:15 < let mem = ListLabels.mem + > let _ = mem ~se + > EOF + { + "class": "return", + "value": { + "signatures": [ + { + "label": "mem : 'a -> set:'a list -> bool", + "parameters": [ + { + "label": [ + 6, + 8 + ] + }, + { + "label": [ + 12, + 23 + ] + } + ] + } + ], + "activeParameter": 1, + "activeSignature": 0 + }, + "notifications": [] + } + +It can make an optional parameter active by prefix. + + $ $MERLIN single signature-help -position 2:18 < let create = Hashtbl.create + > let _ = create ?ra + > EOF + { + "class": "return", + "value": { + "signatures": [ + { + "label": "create : ?random:bool -> int -> ('a, 'b) Hashtbl.t", + "parameters": [ + { + "label": [ + 9, + 21 + ] + }, + { + "label": [ + 25, + 28 + ] + } + ] + } + ], + "activeParameter": 0, + "activeSignature": 0 + }, + "notifications": [] + } + +It shouldn't give a signature-help when outside of signature. + + $ $MERLIN single signature-help -position 1:8 < let my_fun x = 1 + > EOF + { + "class": "return", + "value": {}, + "notifications": [] + }