Skip to content

Commit 63d9f92

Browse files
liam923liam923
committed
Add locate-type-multi command
1 parent 89f01ee commit 63d9f92

File tree

5 files changed

+220
-15
lines changed

5 files changed

+220
-15
lines changed

‎src/analysis/locate_type_multi.ml‎

Lines changed: 17 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -2,8 +2,10 @@ open StdLabels
22

33
module Type_tree = struct
44
type node_data =
5-
| Artificial_node of [ `Arrow | `Tuple ]
6-
| Type of { path : Path.t; ty : Types.type_expr }
5+
| Arrow
6+
| Tuple
7+
| Object
8+
| Type_ref of { path : Path.t; ty : Types.type_expr }
79

810
type t = { data : node_data; children : t list }
911
end
@@ -18,20 +20,27 @@ let rec create_type_tree ty : Type_tree.t option =
1820
| Tarrow (_, ty1, ty2, _) ->
1921
let tys = ty1 :: flatten_arrow ty2 in
2022
let children = List.filter_map tys ~f:create_type_tree in
21-
Some { data = Artificial_node `Arrow; children }
23+
Some { data = Arrow; children }
2224
| Ttuple tys | Tunboxed_tuple tys ->
2325
let children =
2426
List.filter_map tys ~f:(fun (_, ty) -> create_type_tree ty)
2527
in
26-
Some { data = Artificial_node `Tuple; children }
28+
Some { data = Tuple; children }
2729
| Tconstr (path, arg_tys, abbrev_memo) ->
2830
let ty_without_args =
2931
Types.newty2 ~level:Ident.highest_scope (Tconstr (path, [], abbrev_memo))
3032
in
3133
let children = List.filter_map arg_tys ~f:create_type_tree in
32-
Some { data = Type { path; ty = ty_without_args }; children }
34+
Some { data = Type_ref { path; ty = ty_without_args }; children }
3335
| Tlink ty | Tpoly (ty, _) -> create_type_tree ty
34-
| Tobject _ | Tfield _ ->
35-
(* CR-someday: support objects *)
36+
| Tobject (fields_type, _) ->
37+
let rec extract_field_types (ty : Types.type_expr) =
38+
match Types.get_desc ty with
39+
| Tfield (_, _, ty, rest) -> ty :: extract_field_types rest
40+
| _ -> []
41+
in
42+
let field_types = List.rev (extract_field_types fields_type) in
43+
let children = List.filter_map field_types ~f:create_type_tree in
44+
Some { data = Object; children }
45+
| Tnil | Tvar _ | Tsubst _ | Tvariant _ | Tunivar _ | Tpackage _ | Tfield _ ->
3646
None
37-
| Tnil | Tvar _ | Tsubst _ | Tvariant _ | Tunivar _ | Tpackage _ -> None

‎src/analysis/locate_type_multi.mli‎

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,9 @@
11
module Type_tree : sig
22
type node_data =
3-
| Artificial_node of [ `Arrow | `Tuple ]
4-
| Type of { path : Path.t; ty : Types.type_expr }
3+
| Arrow
4+
| Tuple
5+
| Object
6+
| Type_ref of { path : Path.t; ty : Types.type_expr }
57

68
type t = { data : node_data; children : t list }
79
end

‎src/frontend/kernel/query_protocol_kernel.ml‎

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -18,8 +18,10 @@ module Locate_type_multi_result = struct
1818
open Ppx_yojson_conv_lib.Yojson_conv.Primitives
1919

2020
type node_data =
21-
| Artificial_node of [ `Arrow | `Tuple ]
22-
| Type of
21+
| Arrow
22+
| Tuple
23+
| Object
24+
| Type_ref of
2325
{ type_ : string;
2426
result :
2527
[ `Found of string option * Lexing.position

‎src/frontend/query_commands.ml‎

Lines changed: 5 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -509,8 +509,10 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function
509509
Locate_type_multi_result.type_tree =
510510
let data : Locate_type_multi_result.node_data =
511511
match data with
512-
| Artificial_node node -> Artificial_node node
513-
| Type { path; ty } ->
512+
| Arrow -> Arrow
513+
| Tuple -> Tuple
514+
| Object -> Object
515+
| Type_ref { path; ty } ->
514516
Locate.log ~title:"debug" "found type: %s" (Path.name path);
515517
let config : Locate.config =
516518
{ mconfig = Mpipeline.final_config pipeline;
@@ -530,7 +532,7 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a = function
530532
| `File_not_found _ as s -> s
531533
in
532534
let type_ = type_to_string ~env ty in
533-
Type { type_; result }
535+
Type_ref { type_; result }
534536
in
535537
let children = List.map children ~f:make_result in
536538
{ data; children }

‎tests/test-dirs/locate-type-multi.t‎

Lines changed: 190 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,190 @@
1+
Test the locate-type-multi command
2+
3+
Create a function that runs locate-type-multi on a variable of a given type
4+
$ run () {
5+
> type="$1"
6+
>
7+
> # Create a file that creates a variable of the given type. We also define some
8+
> # types for us to be able to reference.
9+
> cat > foo.ml <<EOF
10+
> type a
11+
> type b
12+
> type c
13+
> type 'a one_arg
14+
> type ('a, 'b) two_arg
15+
> type aliased = t
16+
> let () =
17+
> (* This double Obj.magic is to avoid a kind error *)
18+
> let foo : $type = (Obj.magic (Obj.magic 0)) 0 in
19+
> ()
20+
> EOF
21+
>
22+
> $MERLIN single locate-type-multi -position "9:7" -filename foo.ml < foo.ml \
23+
> | jq .value[1] \
24+
> | jq -r '
25+
> def format_node:
26+
> if .data[0] == "Type_ref" then
27+
> # Check if result is null or position info is missing
28+
> if .data[1].result == null or .data[1].result[2] == null then
29+
> # No position info available
30+
> .data[1].type_
31+
> else
32+
> # Extract type_, line number, and calculate column
33+
> .data[1].type_ + " (" +
34+
> (.data[1].result[2].pos_lnum | tostring) + ":" +
35+
> ((.data[1].result[2].pos_cnum - .data[1].result[2].pos_bol) | tostring) +
36+
> ")"
37+
> end
38+
> else
39+
> .data[0]
40+
> end;
41+
>
42+
> def process_tree($indent):
43+
> format_node as $node_text |
44+
> $indent + $node_text +
45+
> if .children | length > 0 then
46+
> "\n" + (.children | map(process_tree($indent + " ")) | join("\n"))
47+
> else
48+
> ""
49+
> end;
50+
>
51+
> process_tree("")
52+
> '
53+
> }
54+
55+
$ run2 () {
56+
> type="$1"
57+
>
58+
> # Create a file that creates a variable of the given type. We also define some
59+
> # types for us to be able to reference.
60+
> cat > foo.ml <<EOF
61+
> type a
62+
> type b
63+
> type c
64+
> type 'a one_arg
65+
> type ('a, 'b) two_arg
66+
> type aliased = t
67+
> let () =
68+
> (* This double Obj.magic is to avoid a kind error *)
69+
> let foo : $type = (Obj.magic (Obj.magic 0)) 0 in
70+
> ()
71+
> EOF
72+
>
73+
> $MERLIN single locate-type-multi -position "9:7" -filename foo.ml < foo.ml \
74+
> | jq .value
75+
> }
76+
77+
Basic type constructors
78+
79+
$ run "a"
80+
a (1:5)
81+
82+
$ run "a one_arg"
83+
one_arg (4:8)
84+
a (1:5)
85+
86+
$ run "(a, b) two_arg"
87+
two_arg (5:14)
88+
a (1:5)
89+
b (2:5)
90+
$ run "(b, a) two_arg"
91+
two_arg (5:14)
92+
b (2:5)
93+
a (1:5)
94+
95+
Functions
96+
97+
$ run "a -> b -> c"
98+
Arrow
99+
a (1:5)
100+
b (2:5)
101+
c (3:5)
102+
103+
$ run "x:a -> ?y:b -> c"
104+
Arrow
105+
a (1:5)
106+
option
107+
b (2:5)
108+
c (3:5)
109+
110+
Tuples
111+
112+
$ run "a * b * c"
113+
Tuple
114+
a (1:5)
115+
b (2:5)
116+
c (3:5)
117+
118+
$ run "x:a * b"
119+
Tuple
120+
a (1:5)
121+
b (2:5)
122+
123+
$ run "#(a * b * c)"
124+
Tuple
125+
a (1:5)
126+
b (2:5)
127+
c (3:5)
128+
129+
$ run "#(x:a * b)"
130+
Tuple
131+
a (1:5)
132+
b (2:5)
133+
134+
Type variables
135+
136+
$ run "_ one_arg"
137+
one_arg (4:8)
138+
139+
$ run "'a one_arg"
140+
one_arg (4:8)
141+
142+
Objects
143+
144+
$ run "<x : a; y : b>"
145+
Object
146+
a (1:5)
147+
b (2:5)
148+
149+
Primitive types
150+
151+
$ run "string"
152+
string
153+
154+
$ run "int"
155+
int
156+
157+
$ run "a option"
158+
option
159+
a (1:5)
160+
161+
$ run "a list"
162+
list
163+
a (1:5)
164+
165+
Compound types
166+
167+
$ run "(a * b) one_arg"
168+
one_arg (4:8)
169+
Tuple
170+
a (1:5)
171+
b (2:5)
172+
173+
$ run "(a option, _) two_arg"
174+
two_arg (5:14)
175+
option
176+
a (1:5)
177+
178+
$ run "a -> b -> #(x:a * b)"
179+
Arrow
180+
a (1:5)
181+
b (2:5)
182+
Tuple
183+
a (1:5)
184+
b (2:5)
185+
186+
$ run "((a one_arg) list) option"
187+
option
188+
list
189+
one_arg (4:8)
190+
a (1:5)

0 commit comments

Comments
 (0)