Signature Help

Add prefix_of_position

Hacky e2e

Map params to json

params e2e

First working test

whoops

Add active_param

More tests

another one

move string functions to std

Format json response

Make json output according to lsp spec

Revert "move string functions to std"

This reverts commit 77853db.

Better command description

Add changelog

CHANGES.md

@@ -3,6 +3,7 @@ merlin NEXT_VERSION
 
   + merlin binary
     - Add a "heap_mbytes" field to Merlin server responses to report heap usage (#1717)
+    - Add `signature-help` command (#1720)
 
 merlin 4.13
 ===========

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

@@ -650,6 +650,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

@@ -214,6 +214,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
@@ -347,6 +351,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
@@ -426,5 +446,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

@@ -839,6 +839,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;