-
Notifications
You must be signed in to change notification settings - Fork 235
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
- Loading branch information
Showing
6 changed files
with
198 additions
and
0 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters