Source file typedtree_traverse.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
# 3 "typedtree_traverse.cppo.ml"
module Analysis = struct
type annotation =
| LocalDefinition of Ident.t
| GlobalDefinition of Ident.t
| Value of Path.t
| Module of Path.t
| ModuleType of Path.t
| Type of Path.t
(** Extract the type path from a constructor_description's result type. *)
let type_path_of_constructor_desc (cstr : Types.constructor_description) =
match Types.get_desc cstr.cstr_res with
| Tconstr (p, _, _) -> Some p
| _ -> None
(** Extract the type path from a label_description's result type. *)
let type_path_of_label_desc (lbl : Types.label_description) =
match Types.get_desc lbl.lbl_res with
| Tconstr (p, _, _) -> Some p
| _ -> None
let expr poses expr =
let exp_loc = expr.Typedtree.exp_loc in
if exp_loc.loc_ghost then ()
else
match expr.exp_desc with
# 30 "typedtree_traverse.cppo.ml"
| Texp_ident (p, _, _, _, _) ->
# 34 "typedtree_traverse.cppo.ml"
poses := (Value p, exp_loc) :: !poses
# 36 "typedtree_traverse.cppo.ml"
| Texp_construct (_, cstr_desc, _, _) -> (
# 40 "typedtree_traverse.cppo.ml"
match type_path_of_constructor_desc cstr_desc with
| Some p -> poses := (Type p, exp_loc) :: !poses
| None -> ())
# 44 "typedtree_traverse.cppo.ml"
| Texp_field (_, _, _, lbl_desc, _, _) -> (
# 48 "typedtree_traverse.cppo.ml"
match type_path_of_label_desc lbl_desc with
| Some p -> poses := (Type p, exp_loc) :: !poses
| None -> ())
| _ -> ()
let pat env (type a) poses : a Typedtree.general_pattern -> unit = function
| { Typedtree.pat_desc; pat_loc; _ } when not pat_loc.loc_ghost ->
let maybe_localvalue id loc =
match Ident_env.identifier_of_loc env loc with
| None -> Some (LocalDefinition id, loc)
| Some _ -> Some (GlobalDefinition id, loc)
in
let () =
match pat_desc with
# 63 "typedtree_traverse.cppo.ml"
| Tpat_var (id, loc, _uid, _, _) -> (
# 69 "typedtree_traverse.cppo.ml"
match maybe_localvalue id loc.loc with
| Some x -> poses := x :: !poses
| None -> ())
# 75 "typedtree_traverse.cppo.ml"
| Tpat_alias (_, id, loc, _uid, _, _, _) -> (
# 81 "typedtree_traverse.cppo.ml"
match maybe_localvalue id loc.loc with
| Some x -> poses := x :: !poses
| None -> ())
| Tpat_construct (_, cstr_desc, _, _) -> (
match type_path_of_constructor_desc cstr_desc with
| Some p -> poses := (Type p, pat_loc) :: !poses
| None -> ())
| Tpat_record (fields, _) ->
List.iter (fun (lid, lbl_desc, _) ->
match type_path_of_label_desc lbl_desc with
| Some p ->
let loc = lid.Asttypes.loc in
if not loc.Location.loc_ghost then
poses := (Type p, loc) :: !poses
| None -> ()) fields
| _ -> ()
in
()
| _ -> ()
let module_binding env poses = function
| { Typedtree.mb_id = Some id; mb_loc; _ } when not mb_loc.loc_ghost -> (
match Ident_env.identifier_of_loc env mb_loc with
| None -> poses := (LocalDefinition id, mb_loc) :: !poses
| Some _ -> poses := (GlobalDefinition id, mb_loc) :: !poses)
| _ -> ()
let module_expr poses mod_expr =
match mod_expr with
| { Typedtree.mod_desc = Tmod_ident (p, _); mod_loc; _ }
when not mod_loc.loc_ghost ->
poses := (Module p, mod_loc) :: !poses
| _ -> ()
let module_type poses mty_expr =
match mty_expr with
| { Typedtree.mty_desc = Tmty_ident (p, _); mty_loc; _ }
when not mty_loc.loc_ghost ->
poses := (ModuleType p, mty_loc) :: !poses
| _ -> ()
let core_type poses ctyp_expr =
match ctyp_expr with
| { Typedtree.ctyp_desc = Ttyp_constr (p, _, _); ctyp_loc; _ }
when not ctyp_loc.loc_ghost ->
poses := (Type p, ctyp_loc) :: !poses
| _ -> ()
let open_declaration poses (od : Typedtree.open_declaration) =
if not od.open_loc.loc_ghost then
match od.open_expr with
| { mod_desc = Tmod_ident (p, _); _ } ->
poses := (Module p, od.open_loc) :: !poses
| _ -> ()
let open_description poses (od : Typedtree.open_description) =
if not od.open_loc.loc_ghost then
let (p, _) = od.open_expr in
poses := (Module p, od.open_loc) :: !poses
let structure_item poses (item : Typedtree.structure_item) =
if not item.str_loc.loc_ghost then
match item.str_desc with
| Tstr_include incl -> (
match incl.incl_mod with
| { mod_desc = Tmod_ident (p, _); _ } ->
poses := (Module p, incl.incl_loc) :: !poses
| _ -> ())
| _ -> ()
let signature_item poses (item : Typedtree.signature_item) =
if not item.sig_loc.loc_ghost then
match item.sig_desc with
# 155 "typedtree_traverse.cppo.ml"
| Tsig_include (incl, _) -> (
# 159 "typedtree_traverse.cppo.ml"
match incl.incl_mod with
| { mty_desc = Tmty_ident (p, _); _ } ->
poses := (ModuleType p, incl.incl_loc) :: !poses
| _ -> ())
| _ -> ()
end
let of_cmt env structure =
let poses = ref [] in
let iter = Tast_iterator.default_iterator in
let module_expr iterator mod_expr =
Analysis.module_expr poses mod_expr;
iter.module_expr iterator mod_expr
in
let expr iterator e =
Analysis.expr poses e;
iter.expr iterator e
in
let pat iterator e =
Analysis.pat env poses e;
iter.pat iterator e
in
let typ iterator ctyp_expr =
Analysis.core_type poses ctyp_expr;
iter.typ iterator ctyp_expr
in
let module_type iterator mty =
Analysis.module_type poses mty;
iter.module_type iterator mty
in
let module_binding iterator mb =
Analysis.module_binding env poses mb;
iter.module_binding iterator mb
in
let open_declaration iterator od =
Analysis.open_declaration poses od;
iter.open_declaration iterator od
in
let open_description iterator od =
Analysis.open_description poses od;
iter.open_description iterator od
in
let structure_item iterator item =
if not item.Typedtree.str_loc.loc_ghost then begin
Analysis.structure_item poses item;
iter.structure_item iterator item
end
in
let signature_item iterator item =
if not item.Typedtree.sig_loc.loc_ghost then begin
Analysis.signature_item poses item;
iter.signature_item iterator item
end
in
let iterator =
{
iter with
expr;
pat;
module_expr;
typ;
module_type;
module_binding;
open_declaration;
open_description;
structure_item;
signature_item;
}
in
iterator.structure iterator structure;
!poses