Skip to content

Commit

Permalink
Signature Help init
Browse files Browse the repository at this point in the history
  • Loading branch information
3Rafal committed Jan 4, 2024
1 parent d989b6b commit 19b1d9c
Show file tree
Hide file tree
Showing 6 changed files with 198 additions and 0 deletions.
156 changes: 156 additions & 0 deletions src/analysis/signature_help.ml
Original file line number Diff line number Diff line change
@@ -0,0 +1,156 @@
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
19 changes: 19 additions & 0 deletions src/analysis/signature_help.mli
Original file line number Diff line number Diff line change
@@ -0,0 +1,19 @@
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
14 changes: 14 additions & 0 deletions src/frontend/ocamlmerlin/new/new_commands.ml
Original file line number Diff line number Diff line change
Expand Up @@ -650,6 +650,20 @@ The return value has the shape:
]
end
;
command "signature-help"
~doc:"Returns signature help"
~spec: [
arg "-position" "<position> Position to complete"
(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"
Expand Down
5 changes: 5 additions & 0 deletions src/frontend/ocamlmerlin/query_json.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -426,5 +430,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 -> `String s
| Version, version ->
`String version
1 change: 1 addition & 0 deletions src/frontend/query_commands.ml
Original file line number Diff line number Diff line change
Expand Up @@ -839,6 +839,7 @@ 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 _ -> "signature help"
| Version ->
Printf.sprintf "The Merlin toolkit version %s, for Ocaml %s\n"
Merlin_config.version Sys.ocaml_version;
3 changes: 3 additions & 0 deletions src/frontend/query_protocol.ml
Original file line number Diff line number Diff line change
Expand Up @@ -196,5 +196,8 @@ type _ t =
| Occurrences(* *)
: [`Ident_at of Msource.position] * [`Project | `Buffer]
-> Location.t list t
| Signature_help
: Msource.position
-> string t
| Version
: string t

0 comments on commit 19b1d9c

Please sign in to comment.