Signature Help

CHANGES.md

@@ -22,10 +22,12 @@ 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)
 
+
 merlin 4.13
 ===========
 Fri Dec  1 15:00:42 CET 2023

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 <https://ocaml.org/manual/lex.html> 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

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

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> 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 <pos> is mandatory"
+      | #Msource.position as pos ->
+        run buffer (Query_protocol.Signature_help pos)
+    end
+  ;
 
   (* Used only for testing *)
   command "dump"

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

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;