Skip to content

Commit 0ae2594

Browse files
dkalinichenko-jsdkalinichenko-js
authored
Merge pull request #208 from oxcaml/kinds-hovers
Add kind-enclosing query
2 parents 8fc2542 + 9da4c66 commit 0ae2594

File tree

9 files changed

+338
-0
lines changed

9 files changed

+338
-0
lines changed

‎src/analysis/kind_enclosing.ml‎

Lines changed: 56 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,56 @@
1+
open Std
2+
open Type_utils
3+
4+
module Kind_info = struct
5+
type t = { kind : Types.jkind_l; env : Env.t }
6+
7+
let mk ~kind ~env = { kind; env }
8+
9+
let from_type ~env ty = { kind = Ctype.estimate_type_jkind env ty; env }
10+
11+
let to_string ~(verbosity : Mconfig.Verbosity.t) { kind; env } =
12+
let kind =
13+
Jkind.normalize ~mode:Require_best
14+
~context:(Ctype.mk_jkind_context_check_principal env)
15+
kind
16+
in
17+
Printtyp.wrap_printing_env ~verbosity env (fun () ->
18+
let format_jkind =
19+
match Mconfig.Verbosity.to_int ~for_smart:0 verbosity > 0 with
20+
| false -> Jkind.format
21+
| true -> Jkind.format_expanded
22+
in
23+
Format.asprintf "%a" format_jkind kind)
24+
end
25+
26+
let loc_contains_cursor (loc : Location.t) ~cursor =
27+
Lexing.compare_pos loc.loc_start cursor < 0
28+
&& Lexing.compare_pos cursor loc.loc_end < 0
29+
30+
let enclosings_of_node ~cursor (env, (node : Browse_raw.node)) :
31+
(Location.t * Kind_info.t) list =
32+
match node with
33+
| Pattern pattern ->
34+
[ (pattern.pat_loc, Kind_info.from_type ~env pattern.pat_type) ]
35+
| Expression expr ->
36+
[ (expr.exp_loc, Kind_info.from_type ~env expr.exp_type) ]
37+
| Core_type core_type ->
38+
let constr_enclosings =
39+
match core_type.ctyp_desc with
40+
| Ttyp_constr (path, ident, _) when loc_contains_cursor ident.loc ~cursor
41+
->
42+
(* TODO: The env here contains placeholder jkinds for types declared in the same
43+
recursive block, which causes under-approximations to be returned in some
44+
cases. *)
45+
let decl = Env.find_type path env in
46+
[ (ident.loc, Kind_info.mk ~kind:decl.type_jkind ~env) ]
47+
| _ -> []
48+
in
49+
constr_enclosings
50+
@ [ (core_type.ctyp_loc, Kind_info.from_type ~env core_type.ctyp_type) ]
51+
| Type_declaration decl ->
52+
[ (decl.typ_loc, Kind_info.mk ~kind:decl.typ_type.type_jkind ~env) ]
53+
| _ -> []
54+
55+
let from_mbrowse mbrowse ~cursor : (Location.t * Kind_info.t) list =
56+
List.concat_map mbrowse ~f:(enclosings_of_node ~cursor)

‎src/analysis/kind_enclosing.mli‎

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,13 @@
1+
(** Provides information about the kind of the thing the cursor is on. If the cursor is
2+
on an expression, it returns the kind of the type of the expression. If the cursor is
3+
on a type, it returns the kind of the type. If the cursor is on a kind abbreviation,
4+
it returns the expansion of the kind abbreviation. *)
5+
6+
module Kind_info : sig
7+
type t
8+
9+
val to_string : verbosity:Mconfig.Verbosity.t -> t -> string
10+
end
11+
12+
val from_mbrowse :
13+
Mbrowse.t -> cursor:Lexing.position -> (Location.t * Kind_info.t) list

‎src/commands/new_commands.ml‎

Lines changed: 35 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -831,6 +831,41 @@ let all_commands =
831831
in
832832
run buffer (Query_protocol.Type_enclosing (expr, pos, index))
833833
end;
834+
command "kind-enclosing"
835+
~doc:
836+
"Returns a list of kind information for all expressions at given \
837+
position, sorted by increasing size.\n\
838+
`-index` can be used to print only the kind information of a entry in \
839+
the result list expression. This is useful to\n\
840+
query the kinds lazily: normally, Merlin would return the kind of all\n\
841+
enclosing modules, which may be very expensive.\n\n\
842+
The result is returned as a list of:\n\
843+
```javascript\n\
844+
{\n\
845+
\ 'start': position,\n\
846+
\ 'end': position,\n\
847+
\ 'kind': (string | int),\n\
848+
}\n\
849+
```"
850+
~spec:
851+
[ arg "-position" "<position> Position to inspect the kind of"
852+
(marg_position (fun pos (_pos, index) -> (pos, index)));
853+
optional "-index" "<int> Only print type of <index>'th result"
854+
(Marg.param "int" (fun index (pos, _index) ->
855+
match int_of_string index with
856+
| index -> (pos, Some index)
857+
| exception _ -> failwith "index should be an integer"))
858+
]
859+
~default:(`None, None)
860+
begin
861+
fun buffer (pos, index) ->
862+
match pos with
863+
| `None -> failwith "-position <pos> is mandatory"
864+
| #Msource.position as position ->
865+
run buffer
866+
(Query_protocol.Kind_enclosing
867+
{ position; index; override_verbosity = None })
868+
end;
834869
command "type-expression"
835870
~doc:
836871
"Returns the type of the expression when typechecked in the \

‎src/commands/query_json.ml‎

Lines changed: 23 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -78,6 +78,19 @@ let dump (type a) : a t -> json =
7878
| Some n -> `Int n );
7979
("position", mk_position pos)
8080
]
81+
| Kind_enclosing { position; index; override_verbosity } ->
82+
mk "kind-enclosing"
83+
([ ( "index",
84+
match index with
85+
| None -> `String "all"
86+
| Some n -> `Int n );
87+
("position", mk_position position)
88+
]
89+
@
90+
match override_verbosity with
91+
| Some (Lvl n) -> [ ("override-verbosity", `Int n) ]
92+
| Some Smart -> [ ("override-verbosity", `String "smart") ]
93+
| None -> [])
8194
| Locate_type pos -> mk "locate-type" [ ("position", mk_position pos) ]
8295
| Locate_types pos -> mk "locate-types" [ ("position", mk_position pos) ]
8396
| Enclosing pos -> mk "enclosing" [ ("position", mk_position pos) ]
@@ -273,6 +286,14 @@ let json_of_type_loc (loc, desc, tail) =
273286
| `Tail_call -> "call") )
274287
]
275288

289+
let json_of_kind_enclosing_res (loc, desc) =
290+
with_location loc
291+
[ ( "kind",
292+
match desc with
293+
| `Kind k -> `String k
294+
| `Index n -> `Int n )
295+
]
296+
276297
let json_of_error (error : Location.error) =
277298
let of_sub loc sub =
278299
let msg =
@@ -490,6 +511,8 @@ let json_of_response (type a) (query : a t) (response : a) : json =
490511
| Stack_or_heap_enclosing _, results ->
491512
`List (List.map ~f:json_of_stack_or_heap results)
492513
| Type_enclosing _, results -> `List (List.map ~f:json_of_type_loc results)
514+
| Kind_enclosing _, results ->
515+
`List (List.map ~f:json_of_kind_enclosing_res results)
493516
| Enclosing _, results ->
494517
`List (List.map ~f:(fun loc -> with_location loc []) results)
495518
| Complete_prefix _, compl -> json_of_completions compl

‎src/frontend/query_commands.ml‎

Lines changed: 25 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -370,6 +370,31 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function
370370
let printed_type = Type_enclosing.print_type ~verbosity type_info in
371371
ret (`String printed_type)
372372
else ret (`Index i))
373+
| Kind_enclosing { position; index; override_verbosity } ->
374+
let typer = Mpipeline.typer_result pipeline in
375+
let cursor = Mpipeline.get_lexing_pos pipeline position in
376+
let verbosity =
377+
match override_verbosity with
378+
| Some verbosity -> verbosity
379+
| None -> verbosity pipeline
380+
in
381+
let mbrowse_at_cursor =
382+
Mbrowse.enclosing cursor
383+
[ Mbrowse.of_typedtree (Mtyper.get_typedtree typer) ]
384+
in
385+
let enclosings = Kind_enclosing.from_mbrowse mbrowse_at_cursor ~cursor in
386+
List.mapi enclosings ~f:(fun i (loc, kind) ->
387+
let should_print =
388+
match index with
389+
| Some index -> index = i
390+
| None -> true
391+
in
392+
let kind_info =
393+
match should_print with
394+
| true -> `Kind (Kind_enclosing.Kind_info.to_string ~verbosity kind)
395+
| false -> `Index i
396+
in
397+
(loc, kind_info))
373398
| Enclosing pos ->
374399
let typer = Mpipeline.typer_result pipeline in
375400
let structures = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in

‎src/frontend/query_protocol.ml‎

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -221,6 +221,14 @@ type _ t =
221221
| Stack_or_heap_enclosing (* *) :
222222
Msource.position * bool * int option
223223
-> (Location.t * [ `String of string | `Index of int ]) list t
224+
| Kind_enclosing (* *) :
225+
{ position : Msource.position;
226+
index : int option;
227+
override_verbosity : Mconfig.Verbosity.t option
228+
(** Use a different verbosity for printing kinds than as specified by the
229+
Mconfig. *)
230+
}
231+
-> (Location.t * [ `Kind of string | `Index of int ]) list t
224232
| Type_enclosing (* *) :
225233
(string * int) option * Msource.position * int option
226234
-> (Location.t * [ `String of string | `Index of int ] * is_tail_position)

‎tests/test-dirs/kind-enclosing/agree-with-typedecl.t‎

Lines changed: 66 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,66 @@
1+
This file tests that the first enclosing returned by kind-enclosing agrees with that of
2+
type-enclosing. This is useful because the LSP might want to only display the
3+
kind-enclosing in a hover if it is for the same expression as the type-enclosing hover.
4+
5+
$ run() {
6+
> cat > test.ml
7+
> kind=$(
8+
> $MERLIN single kind-enclosing -position $1 -filename test.ml < test.ml \
9+
> | jq -r '.value[0] | "\(.start.line):\(.start.col)-\(.end.line):\(.end.col)"')
10+
> type=$(
11+
> $MERLIN single type-enclosing -position $1 -filename test.ml < test.ml \
12+
> | jq -r '.value[0] | "\(.start.line):\(.start.col)-\(.end.line):\(.end.col)"')
13+
> if [ "$kind" = "$type" ]; then
14+
> echo "Agree"
15+
> else
16+
> echo "Disagree: kind=$kind, type=$type"
17+
> fi
18+
> }
19+
20+
$ run 1:5 <<EOF
21+
> type t
22+
> EOF
23+
Agree
24+
25+
$ run 1:9 <<EOF
26+
> type t = int
27+
> EOF
28+
Agree
29+
30+
$ run 1:9 <<EOF
31+
> type t = int option
32+
> EOF
33+
Agree
34+
35+
$ run 1:16 <<EOF
36+
> type t = int option
37+
> EOF
38+
Agree
39+
40+
$ run 1:5 <<EOF
41+
> let foo bar = bar
42+
> EOF
43+
Agree
44+
45+
$ run 1:9 <<EOF
46+
> let foo bar = bar
47+
> EOF
48+
Agree
49+
50+
$ run 1:15 <<EOF
51+
> let foo bar = bar
52+
> EOF
53+
Agree
54+
55+
$ run 2:14 <<EOF
56+
> let foo =
57+
> let x = 1 + 2 + 3 in
58+
> x
59+
> EOF
60+
Agree
61+
62+
$ run 2:10 <<EOF
63+
> let f = function
64+
> | Some (foo, bar) -> foo
65+
> EOF
66+
Agree

‎tests/test-dirs/kind-enclosing/basic.t‎

Lines changed: 79 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,79 @@
1+
$ run() {
2+
> $MERLIN single kind-enclosing -position $1 \
3+
> | jq -r '.value[] | "\(.start.line):\(.start.col)-\(.end.line):\(.end.col): \(.kind)"'
4+
> }
5+
6+
$ run 1:5 <<EOF
7+
> type t = int
8+
> EOF
9+
1:0-1:12: immediate
10+
11+
$ run 1:9 <<EOF
12+
> type 'a t = int
13+
> EOF
14+
1:0-1:15: immediate
15+
16+
$ run 1:9 <<EOF
17+
> type t = int option
18+
> EOF
19+
1:9-1:12: immediate
20+
1:9-1:19: immutable_data
21+
1:0-1:19: immutable_data
22+
23+
$ run 1:16 <<EOF
24+
> type t = int option
25+
> EOF
26+
1:13-1:19: immutable_data with 'a
27+
1:9-1:19: immutable_data
28+
1:0-1:19: immutable_data
29+
30+
$ run 1:18 <<EOF
31+
> type 'a t = 'a option
32+
> EOF
33+
1:15-1:21: immutable_data with 'a
34+
1:12-1:21: immutable_data with 'a
35+
1:0-1:21: immutable_data with 'a
36+
37+
$ run 1:44 <<EOF
38+
> type 'a my_list = Nil | Cons of 'a * 'a my_list
39+
> EOF
40+
1:40-1:47: any
41+
1:37-1:47: any
42+
1:0-1:47: immutable_data with 'a
43+
44+
$ run 1:24 <<EOF
45+
> type 'a t1 = Rec of 'a t2 | Leaf of 'a
46+
> and 'a t2 = Rec of 'a t1 | None
47+
> EOF
48+
1:23-1:25: any
49+
1:20-1:25: any
50+
1:0-1:38: immutable_data with 'a
51+
52+
$ run 1:22 <<EOF
53+
> type 'a t1 = Rec of 'a t2 | Leaf of 'a
54+
> and 'a t2 = Rec of 'a t1 | None
55+
> EOF
56+
1:20-1:22: value
57+
1:20-1:25: any
58+
1:0-1:38: immutable_data with 'a
59+
60+
$ run 2:6 <<EOF
61+
> type 'a t1
62+
> type t2 = Foo of int t1
63+
> EOF
64+
2:0-2:23: immutable_data with int t1
65+
66+
$ run 1:14 <<EOF
67+
> let f (foo : int) =
68+
> foo
69+
> EOF
70+
1:13-1:16: immediate
71+
1:13-1:16: immediate
72+
1:6-2:5: value mod aliased immutable non_float
73+
74+
$ run 2:4 <<EOF
75+
> let f (foo : int) =
76+
> foo
77+
> EOF
78+
2:2-2:5: immediate
79+
1:6-2:5: value mod aliased immutable non_float

‎tests/test-dirs/kind-enclosing/verbosity.t‎

Lines changed: 33 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,33 @@
1+
$ run() {
2+
> cat > test.ml
3+
> i=0
4+
> while [ "$i" -le 2 ]; do
5+
> $MERLIN single kind-enclosing -position "$1" -verbosity "$i" < test.ml \
6+
> | jq -r "\"Verbosity $i: \(.value[0].kind)\""
7+
> i=$(($i+1))
8+
> done
9+
> }
10+
11+
TODO: Verbosity=2 should show all axes, even when max.
12+
13+
$ run 1:9 <<EOF
14+
> type t = int
15+
> EOF
16+
Verbosity 0: immediate
17+
Verbosity 1: value mod global many stateless immutable external_ non_float
18+
Verbosity 2: value mod global many stateless immutable external_ non_float
19+
20+
$ run 1:17 <<EOF
21+
> type 'a t = 'a option
22+
> EOF
23+
Verbosity 0: immutable_data with 'a
24+
Verbosity 1: value mod forkable unyielding many stateless immutable non_float with 'a
25+
Verbosity 2: value mod forkable unyielding many stateless immutable non_float with 'a
26+
27+
$ run 2:6 <<EOF
28+
> type 'a t1
29+
> type t2 = Foo of int t1
30+
> EOF
31+
Verbosity 0: immutable_data with int t1
32+
Verbosity 1: value mod forkable unyielding many stateless immutable non_float with int t1
33+
Verbosity 2: value mod forkable unyielding many stateless immutable non_float with int t1

0 commit comments

Comments
 (0)