[B] ocaml#1720 Signature Help

CHANGES.md

@@ -8,6 +8,7 @@ unreleased
     - destruct: Refinement in the presence of optional arguments (#1800 #1807, fixes #1770)
     - Implement new expand-node command for expanding PPX annotations (#1745)
     - Implement new inlay-hints command for adding hints on a sourcetree (#1812)
+    - Add `signature-help` command (#1720)
   + editor modes
     - vim: fix python-3.12 syntax warnings in merlin.py (#1798)
     - vim: Dead code / doc removal for previously deleted MerlinPhrase command (#1804)

src/analysis/signature_help.ml

@@ -0,0 +1,260 @@
+open Std
+
+let {Logger. log} = Logger.for_section "signature-help"
+
+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)
+
+let rec type_is_arrow ty =
+  match Types.get_desc ty with
+  | Tarrow _ -> true
+  | Tlink ty -> type_is_arrow ty
+  | Tpoly (ty, _) -> type_is_arrow ty
+  | _ -> false
+
+(* surround function types in parentheses *)
+let pp_parameter_type env ppf ty =
+  if type_is_arrow ty then Format.fprintf ppf "(%a)" (pp_type env) ty
+  else 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 }
+
+(* This function preprocesses the signature and associate already assigned
+arguments to the corresponding parameter. (They should always be in the correct
+order in the typedtree, even if they are not in order in the source file.) *)
+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 ?(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 ~parameters:(parameter :: parameters)
+    | [], Tarrow (label, ty1, ty2, _) ->
+      let parameter = print_parameter_offset ppf buffer e.exp_env label ty1 in
+      separate args ty2 ~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 first_unassigned_argument params =
+  let positional = function
+    | { argument = None; label = Asttypes.Nolabel; _ } -> true
+    | _ -> false
+  in
+  let labelled = function
+    | { argument = None; label = Asttypes.Labelled _ | Optional _; _ } -> true
+    | _ -> false
+  in
+  try Some (List.index params ~f:positional) with Not_found ->
+    try Some (List.index params ~f:labelled) 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 ~cursor = function
+  | (_, Browse_raw.Expression arg)
+    :: ( _
+       , Expression { exp_desc = Texp_apply (({ exp_type; _ } as e), args); _ }
+       )
+    :: _
+    when is_arrow exp_type ->
+    log ~title:"application_signature" "Last arg:\n%a"
+      Logger.fmt (fun fmt -> Printtyped.expression fmt arg);
+    let result = separate_function_signature e ~args in
+    let active_param =
+      if prefix = "" && Lexing.compare_pos cursor arg.exp_loc.loc_end  > 0 then
+      begin
+        (* If the cursor is placed after the last arg it means that a whitespace
+           was inserted and we want to underline the next argument. *)
+        log ~title:"application_signature"
+          "Current cursor position is after the last argument";
+        first_unassigned_argument result.parameters
+      end else
+        (* If not, we identify the argument which is being written *)
+        let active_param =
+          active_parameter_by_arg ~arg result.parameters
+        in
+        match active_param with
+        | Some _ as ap -> ap
+        | None -> active_parameter_by_prefix ~prefix result.parameters
+    in
+    Some { result with active_param }
+  | (_, Expression ({ exp_type; _ } as e)) :: _ when is_arrow exp_type ->
+    (* provide signature information directly after an unapplied function-type
+       value *)
+    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
+
+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: *)
+    log ~title:"prefix_of_position" "%S" reconstructed_prefix;
+    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,28 @@
+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
+  }
+
+(** provide signature information for applied functions *)
+val application_signature :
+     prefix:string
+  -> cursor:Lexing.position
+  -> Mbrowse.t
+  -> application_signature option
+
+(** @see <https://ocaml.org/manual/lex.html> reference *)
+val prefix_of_position :
+    short_path: bool
+  -> Msource.t
+  -> Msource.position
+  -> string

src/commands/new_commands.ml

@@ -754,6 +754,26 @@ 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 position ->
+        let sh = {
+          Query_protocol.position;
+          trigger_kind = None;
+          is_retrigger = false;
+          active_signature_help = None;
+        } in
+        run buffer (Query_protocol.Signature_help sh)
+    end
+  ;
 
   (* Used only for testing *)
   command "dump"

src/commands/query_json.ml

@@ -226,6 +226,10 @@ let dump (type a) : a t -> json =
                                          | `Unqualify -> "unqualify");
       "position", mk_position pos;
     ]
+  | Signature_help {position;_} ->
+    mk "signature-help" [
+      "position", mk_position position
+    ]
   | Version -> mk "version" []
 
 let string_of_completion_kind = function
@@ -367,6 +371,22 @@ let json_of_inlay_hints hints =
      ]
   in `List (List.map ~f:json_of_hint hints)
 
+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
@@ -400,7 +420,7 @@ let json_of_response (type a) (query : a t) (response : a) : json =
       | `Found doc ->
         `String doc
     end
-  | Syntax_document _, resp -> 
+  | Syntax_document _, resp ->
     (match resp with
     | `Found info ->
       `Assoc
@@ -410,9 +430,9 @@ let json_of_response (type a) (query : a t) (response : a) : json =
         ("url", `String info.documentation);
       ]
     | `No_documentation -> `String "No documentation found")
-  | Expand_ppx _, resp -> 
+  | Expand_ppx _, resp ->
     let str = match resp with
-    | `Found ppx_info -> 
+    | `Found ppx_info ->
       `Assoc
       [
         ("code", `String ppx_info.code);
@@ -471,5 +491,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