-
-
Notifications
You must be signed in to change notification settings - Fork 648
/
displayToplevel.ml
524 lines (480 loc) · 18.3 KB
/
displayToplevel.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
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
(*
The Haxe Compiler
Copyright (C) 2005-2019 Haxe Foundation
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
*)
open Ast
open Common
open CompilationServer
open Type
open Typecore
open CompletionItem
open ClassFieldOrigin
open DisplayTypes
open Genjson
open Globals
let maybe_resolve_macro_field ctx t c cf =
try
if cf.cf_kind <> Method MethMacro then raise Exit;
let (tl,tr,c,cf) = ctx.g.do_load_macro ctx false c.cl_path cf.cf_name null_pos in
(TFun(tl,tr)),c,cf
with _ ->
t,c,cf
let exclude : string list ref = ref []
class explore_class_path_task cs com recursive f_pack f_module dir pack = object(self)
inherit server_task ["explore";dir] 50
method private execute : unit =
let dot_path = (String.concat "." (List.rev pack)) in
if (List.mem dot_path !exclude) then
()
else try
let entries = Sys.readdir dir in
Array.iter (fun file ->
match file with
| "." | ".." ->
()
| _ when Sys.is_directory (dir ^ file) && file.[0] >= 'a' && file.[0] <= 'z' ->
begin try
begin match PMap.find file com.package_rules with
| Forbidden | Remap _ -> ()
| _ -> raise Not_found
end
with Not_found ->
f_pack (List.rev pack,file);
if recursive then begin
let task = new explore_class_path_task cs com recursive f_pack f_module (dir ^ file ^ "/") (file :: pack) in
begin match cs with
| None -> task#run
| Some cs' -> cs'#add_task task
end
end
end
| _ ->
let l = String.length file in
if l > 3 && String.sub file (l - 3) 3 = ".hx" then begin
try
let name = String.sub file 0 (l - 3) in
let path = (List.rev pack,name) in
let dot_path = if dot_path = "" then name else dot_path ^ "." ^ name in
if (List.mem dot_path !exclude) then () else f_module (dir ^ file) path;
with _ ->
()
end
) entries;
with Sys_error _ ->
()
end
let explore_class_paths com timer class_paths recursive f_pack f_module =
let cs = CompilationServer.get() in
let t = Timer.timer (timer @ ["class path exploration"]) in
let tasks = List.map (fun dir ->
new explore_class_path_task cs com recursive f_pack f_module dir []
) class_paths in
begin match cs with
| None -> List.iter (fun task -> task#run) tasks
| Some cs -> List.iter (fun task -> cs#add_task task) tasks
end;
t()
let read_class_paths com timer =
explore_class_paths com timer (List.filter ((<>) "") com.class_path) true (fun _ -> ()) (fun file path ->
(* Don't parse the display file as that would maybe overwrite the content from stdin with the file contents. *)
if not (DisplayPosition.display_position#is_in_file file) then begin
let file,_,pack,_ = Display.parse_module' com path Globals.null_pos in
match CompilationServer.get() with
| Some cs when pack <> fst path ->
let file = Path.unique_full_path file in
(CommonCache.get_cache cs com)#remove_file_for_real file
| _ ->
()
end
)
let init_or_update_server cs com timer_name =
let cc = CommonCache.get_cache cs com in
if not cc#is_initialized then begin
cc#set_initialized true;
read_class_paths com timer_name
end;
(* Force executing all "explore" tasks here because we need their information. *)
cs#run_tasks true (fun task -> match task#get_id with
| "explore" :: _ -> true
| _ -> false
);
(* Iterate all removed files of the current context. If they aren't part of the context again,
re-parse them and remove them from c_removed_files. *)
let removed_files = cc#get_removed_files in
let removed_removed_files = DynArray.create () in
Hashtbl.iter (fun file () ->
DynArray.add removed_removed_files file;
try
ignore(cc#find_file file);
with Not_found ->
try ignore(TypeloadParse.parse_module_file com file null_pos) with _ -> ()
) removed_files;
DynArray.iter (Hashtbl.remove removed_files) removed_removed_files
module CollectionContext = struct
open ImportStatus
type t = {
ctx : typer;
items : CompletionItem.t DynArray.t;
names : (string,CompletionItem.t) Hashtbl.t;
paths : (Globals.path,bool) Hashtbl.t;
}
let create ctx = {
ctx = ctx;
items = DynArray.create ();
names = Hashtbl.create 0;
paths = Hashtbl.create 0;
}
let add_item ctx item name =
DynArray.add ctx.items item;
match name with
| None -> ()
| Some name -> Hashtbl.replace ctx.names name item
let get_import_status ctx is_import path =
try
let _ = Hashtbl.find ctx.names (snd path) in
(* TODO: do we have to check if we get the same thing? *)
Shadowed
with Not_found ->
let check_wildcard () =
List.exists (fun (sl,_) -> (sl,snd path) = path) ctx.ctx.m.wildcard_packages
in
if is_import || (fst path = []) || check_wildcard () then Imported else Unimported
let is_qualified ctx name =
not (Hashtbl.mem ctx.names name)
let path_exists ctx path = Hashtbl.mem ctx.paths path
let add_path ctx path = Hashtbl.add ctx.paths path true
end
open CollectionContext
(* +1 for each matching package part. 0 = no common part *)
let pack_similarity pack1 pack2 =
let rec loop count pack1 pack2 = match pack1,pack2 with
| [],[] -> count
| (s1 :: pack1),(s2 :: pack2) when s1 = s2 -> loop (count + 1) pack1 pack2
| _ -> count
in
loop 0 pack1 pack2
(* Returns `true` if `pack1` contains or is `pack2` *)
let pack_contains pack1 pack2 =
let rec loop pack1 pack2 = match pack1,pack2 with
| [],_ -> true
| (s1 :: pack1),(s2 :: pack2) when s1 = s2 -> loop pack1 pack2
| _ -> false
in
loop pack1 pack2
let is_pack_visible pack =
not (List.exists (fun s -> String.length s > 0 && s.[0] = '_') pack)
let collect ctx tk with_type sort =
let t = Timer.timer ["display";"toplevel"] in
let cctx = CollectionContext.create ctx in
let curpack = fst ctx.curclass.cl_path in
(* Note: This checks for the explicit `ServerConfig.legacy_completion` setting instead of using
`is_legacy_completion com` because the latter is always false for the old protocol, yet we have
tests which assume advanced completion even in the old protocol. This means that we can only
use "legacy mode" in the new protocol. *)
let is_legacy_completion = !ServerConfig.legacy_completion in
let packages = Hashtbl.create 0 in
let add_package path = Hashtbl.replace packages path true in
let add item name = add_item cctx item name in
let add_type mt =
match mt with
| TClassDecl {cl_kind = KAbstractImpl _ | KModuleStatics _} -> ()
| _ ->
let path = (t_infos mt).mt_path in
let mname = snd (t_infos mt).mt_module.m_path in
let path = if snd path = mname then path else (fst path @ [mname],snd path) in
if not (path_exists cctx path) then begin
Display.merge_core_doc ctx mt;
let is = get_import_status cctx true path in
if not (Meta.has Meta.NoCompletion (t_infos mt).mt_meta) then begin
add (make_ci_type (CompletionModuleType.of_module_type mt) is None) (Some (snd path));
add_path cctx path;
end
end
in
let process_decls pack name decls =
let added_something = ref false in
let add item name =
added_something := true;
add item name
in
let run () = List.iter (fun (d,p) ->
begin try
let tname,is_private,meta = match d with
| EClass d -> fst d.d_name,List.mem HPrivate d.d_flags,d.d_meta
| EEnum d -> fst d.d_name,List.mem EPrivate d.d_flags,d.d_meta
| ETypedef d -> fst d.d_name,List.mem EPrivate d.d_flags,d.d_meta
| EAbstract d -> fst d.d_name,List.mem AbPrivate d.d_flags,d.d_meta
| _ -> raise Exit
in
let path = Path.full_dot_path pack name tname in
if not (path_exists cctx path) && not is_private && not (Meta.has Meta.NoCompletion meta) then begin
add_path cctx path;
(* If we share a package, the module's main type shadows everything with the same name. *)
let shadowing_name = if pack_contains pack curpack && tname = name then (Some name) else None in
(* Also, this means we can access it as if it was imported (assuming it's not shadowed by something else. *)
let is = get_import_status cctx (shadowing_name <> None) path in
add (make_ci_type (CompletionModuleType.of_type_decl pack name (d,p)) is None) shadowing_name
end
with Exit ->
()
end
) decls in
if is_pack_visible pack then run();
!added_something
in
(* Collection starts here *)
let tpair ?(values=PMap.empty) t =
let ct = CompletionType.from_type (Display.get_import_status ctx) ~values t in
(t,ct)
in
begin match tk with
| TKType | TKOverride -> ()
| TKExpr p | TKPattern p | TKField p ->
(* locals *)
PMap.iter (fun _ v ->
if not (is_gen_local v) then
add (make_ci_local v (tpair ~values:(get_value_meta v.v_meta) v.v_type)) (Some v.v_name)
) ctx.locals;
let add_field scope origin cf =
let origin,cf = match origin with
| Self (TClassDecl c) ->
let _,c,cf = maybe_resolve_macro_field ctx cf.cf_type c cf in
Self (TClassDecl c),cf
| StaticImport (TClassDecl c) ->
let _,c,cf = maybe_resolve_macro_field ctx cf.cf_type c cf in
StaticImport (TClassDecl c),cf
| Parent (TClassDecl c) ->
let _,c,cf = maybe_resolve_macro_field ctx cf.cf_type c cf in
Parent (TClassDecl c),cf
| StaticExtension (TClassDecl c) ->
let _,c,cf = maybe_resolve_macro_field ctx cf.cf_type c cf in
StaticExtension (TClassDecl c),cf
| _ ->
origin,cf
in
let is_qualified = is_qualified cctx cf.cf_name in
add (make_ci_class_field (CompletionClassField.make cf scope origin is_qualified) (tpair ~values:(get_value_meta cf.cf_meta) cf.cf_type)) (Some cf.cf_name)
in
let maybe_add_field scope origin cf =
if not (Meta.has Meta.NoCompletion cf.cf_meta) then add_field scope origin cf
in
(* member fields *)
if ctx.curfun <> FunStatic then begin
let all_fields = Type.TClass.get_all_fields ctx.curclass (List.map snd ctx.curclass.cl_params) in
PMap.iter (fun _ (c,cf) ->
let origin = if c == ctx.curclass then Self (TClassDecl c) else Parent (TClassDecl c) in
maybe_add_field CFSMember origin cf
) all_fields;
(* TODO: local using? *)
end;
(* statics *)
begin match ctx.curclass.cl_kind with
| KAbstractImpl ({a_impl = Some c} as a) ->
let origin = Self (TAbstractDecl a) in
List.iter (fun cf ->
if Meta.has Meta.Impl cf.cf_meta then begin
if ctx.curfun = FunStatic then ()
else begin
let cf = prepare_using_field cf in
maybe_add_field CFSMember origin cf
end
end else
maybe_add_field CFSStatic origin cf
) c.cl_ordered_statics
| _ ->
List.iter (maybe_add_field CFSStatic (Self (TClassDecl ctx.curclass))) ctx.curclass.cl_ordered_statics
end;
(* enum constructors *)
let rec enum_ctors t =
match t with
| TAbstractDecl ({a_impl = Some c} as a) when Meta.has Meta.Enum a.a_meta && not (path_exists cctx a.a_path) && ctx.curclass != c ->
add_path cctx a.a_path;
List.iter (fun cf ->
let ccf = CompletionClassField.make cf CFSMember (Self (decl_of_class c)) true in
if (Meta.has Meta.Enum cf.cf_meta) && not (Meta.has Meta.NoCompletion cf.cf_meta) then
add (make_ci_enum_abstract_field a ccf (tpair cf.cf_type)) (Some cf.cf_name);
) c.cl_ordered_statics
| TTypeDecl t ->
begin match follow t.t_type with
| TEnum (e,_) -> enum_ctors (TEnumDecl e)
| _ -> ()
end
| TEnumDecl e when not (path_exists cctx e.e_path) ->
add_path cctx e.e_path;
let origin = Self (TEnumDecl e) in
PMap.iter (fun _ ef ->
let is_qualified = is_qualified cctx ef.ef_name in
add (make_ci_enum_field (CompletionEnumField.make ef origin is_qualified) (tpair ef.ef_type)) (Some ef.ef_name)
) e.e_constrs;
| _ ->
()
in
List.iter enum_ctors ctx.m.curmod.m_types;
List.iter enum_ctors (List.map fst ctx.m.module_types);
(* enum constructors of expected type *)
begin match with_type with
| WithType.WithType(t,_) ->
(try enum_ctors (module_type_of_type (follow t)) with Exit -> ())
| _ -> ()
end;
(* imported globals *)
PMap.iter (fun name (mt,s,_) ->
try
let is_qualified = is_qualified cctx name in
let class_import c =
let cf = PMap.find s c.cl_statics in
let cf = if name = cf.cf_name then cf else {cf with cf_name = name} in
let decl,make = match c.cl_kind with
| KAbstractImpl a -> TAbstractDecl a,
if Meta.has Meta.Enum cf.cf_meta then make_ci_enum_abstract_field a else make_ci_class_field
| _ -> TClassDecl c,make_ci_class_field
in
let origin = StaticImport decl in
add (make (CompletionClassField.make cf CFSStatic origin is_qualified) (tpair ~values:(get_value_meta cf.cf_meta) cf.cf_type)) (Some name)
in
match resolve_typedef mt with
| TClassDecl c -> class_import c;
| TEnumDecl en ->
let ef = PMap.find s en.e_constrs in
let ef = if name = ef.ef_name then ef else {ef with ef_name = name} in
let origin = StaticImport (TEnumDecl en) in
add (make_ci_enum_field (CompletionEnumField.make ef origin is_qualified) (tpair ef.ef_type)) (Some s)
| TAbstractDecl {a_impl = Some c} -> class_import c;
| _ -> raise Not_found
with Not_found ->
()
) ctx.m.module_globals;
(* literals *)
add (make_ci_literal "null" (tpair t_dynamic)) (Some "null");
add (make_ci_literal "true" (tpair ctx.com.basic.tbool)) (Some "true");
add (make_ci_literal "false" (tpair ctx.com.basic.tbool)) (Some "false");
begin match ctx.curfun with
| FunMember | FunConstructor | FunMemberClassLocal ->
let t = TInst(ctx.curclass,List.map snd ctx.curclass.cl_params) in
add (make_ci_literal "this" (tpair t)) (Some "this");
begin match ctx.curclass.cl_super with
| Some(c,tl) -> add (make_ci_literal "super" (tpair (TInst(c,tl)))) (Some "super")
| None -> ()
end
| _ ->
()
end;
if not is_legacy_completion then begin
(* keywords *)
let kwds = [
Function; Var; Final; If; Else; While; Do; For; Break; Return; Continue; Switch;
Try; New; Throw; Untyped; Cast; Inline;
] in
List.iter (fun kwd -> add(make_ci_keyword kwd) (Some (s_keyword kwd))) kwds;
(* builtins *)
add (make_ci_literal "trace" (tpair (TFun(["value",false,t_dynamic],ctx.com.basic.tvoid)))) (Some "trace")
end
end;
(* type params *)
List.iter (fun (s,t) -> match follow t with
| TInst(c,_) ->
add (make_ci_type_param c (tpair t)) (Some (snd c.cl_path))
| _ -> assert false
) ctx.type_params;
(* module types *)
List.iter add_type ctx.m.curmod.m_types;
(* module imports *)
List.iter add_type (List.rev_map fst ctx.m.module_types); (* reverse! *)
(* types from files *)
begin match !CompilationServer.instance with
| None ->
(* offline: explore class paths *)
let class_paths = ctx.com.class_path in
let class_paths = List.filter (fun s -> s <> "") class_paths in
explore_class_paths ctx.com ["display";"toplevel"] class_paths true add_package (fun file path ->
if not (path_exists cctx path) then begin
let _,decls = Display.parse_module ctx path Globals.null_pos in
ignore(process_decls (fst path) (snd path) decls)
end
)
| Some cs ->
(* online: iter context files *)
init_or_update_server cs ctx.com ["display";"toplevel"];
let cc = CommonCache.get_cache cs ctx.com in
let files = cc#get_files in
(* Sort files by reverse distance of their package to our current package. *)
let files = Hashtbl.fold (fun file cfile acc ->
let i = pack_similarity curpack cfile.c_package in
((file,cfile),i) :: acc
) files [] in
let files = List.sort (fun (_,i1) (_,i2) -> -compare i1 i2) files in
let check_package pack = match List.rev pack with
| [] -> ()
| s :: sl -> add_package (List.rev sl,s)
in
List.iter (fun ((file,cfile),_) ->
let module_name = CompilationServer.get_module_name_of_cfile file cfile in
let dot_path = s_type_path (cfile.c_package,module_name) in
(* In legacy mode we only show toplevel types. *)
if is_legacy_completion && cfile.c_package <> [] then begin
(* And only toplevel packages. *)
match cfile.c_package with
| [s] -> add_package ([],s)
| _ -> ()
end else if (List.exists (fun e -> ExtString.String.starts_with dot_path (e ^ ".")) !exclude) then
()
else begin
Hashtbl.replace ctx.com.module_to_file (cfile.c_package,module_name) file;
if process_decls cfile.c_package module_name cfile.c_decls then check_package cfile.c_package;
end
) files;
List.iter (fun file ->
match cs#get_native_lib file with
| Some lib ->
Hashtbl.iter (fun path (pack,decls) ->
if process_decls pack (snd path) decls then check_package pack;
) lib.c_nl_files
| None ->
()
) ctx.com.native_libs.all_libs
end;
(* packages *)
Hashtbl.iter (fun path _ ->
let full_pack = fst path @ [snd path] in
if is_pack_visible full_pack then add (make_ci_package path []) (Some (snd path))
) packages;
(* sorting *)
let l = DynArray.to_list cctx.items in
let l = if is_legacy_completion then
List.sort (fun item1 item2 -> compare (get_name item1) (get_name item2)) l
else if sort then
Display.sort_fields l with_type tk
else
l
in
t();
l
let collect_and_raise ctx tk with_type cr (name,pname) pinsert =
let fields = match !DisplayException.last_completion_pos with
| Some p' when pname.pmin = p'.pmin ->
Array.to_list (!DisplayException.last_completion_result)
| _ ->
collect ctx tk with_type (name = "")
in
DisplayException.raise_fields fields cr (make_subject (Some name) ~start_pos:(Some pname) pinsert)
let handle_unresolved_identifier ctx i p only_types =
let l = collect ctx (if only_types then TKType else TKExpr p) NoValue false in
let cl = List.map (fun it ->
let s = CompletionItem.get_name it in
let i = StringError.levenshtein i s in
(s,it,i),i
) l in
let cl = List.sort (fun (_,c1) (_,c2) -> compare c1 c2) cl in
let cl = StringError.filter_similar (fun (s,_,_) r -> r <= (min (String.length s) (String.length i)) / 3) cl in
ctx.com.display_information.unresolved_identifiers <- (i,p,cl) :: ctx.com.display_information.unresolved_identifiers