Source file dap.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
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
(** Engine supporting parts of the debug adapter protocol *)
open Mopsa_utils
open Core.All
open Toplevel
open Location
open Callstack
open Format
open Yojson.Basic
open Yojson.Basic.Util
open Breakpoint
open Interface
open Query
module IntMap = MapExt.IntMap
module StringMap = MapExt.StringMap
open Toplevel
open Action
open Envdb
module Make(Toplevel : TOPLEVEL) =
struct
(** Variables references *)
type value =
| Leaf of string
| Compound of int
let vref_counter = ref 0
let compute_vrefs pobj =
let vrefs = ref IntMap.empty in
let rec iter = function
| Map(m, _) ->
incr vref_counter;
let vref = !vref_counter in
let children =
MapExtPoly.fold
(fun k v acc ->
let name = Format.asprintf "%a" pp_print_object k in
let vv =
match k with
| Var _ -> Leaf (Format.asprintf "%a" pp_print_object v)
| _ -> iter v
in
(name, vv) :: acc
) m []
in
vrefs := IntMap.add vref (List.rev children) !vrefs;
Compound vref
| List(l, _) ->
incr vref_counter;
let vref = !vref_counter in
let children =
List.mapi
(fun i v ->
string_of_int i, iter v
) l
in
vrefs := IntMap.add vref children !vrefs;
Compound vref
| Set(s, _) ->
incr vref_counter;
let vref = !vref_counter in
let children =
SetExtPoly.elements s |>
List.mapi (fun i v -> string_of_int i, iter v)
in
vrefs := IntMap.add vref children !vrefs;
Compound vref
| pobj ->
let s = Format.asprintf "%a" pp_print_object pobj in
Leaf s
in
let _ = iter pobj in
!vrefs
let compute_scopes_vrefs pobj =
let initial_vref = !vref_counter in
let vrefs = ref (compute_vrefs pobj) in
if IntMap.is_empty !vrefs then
IntMap.empty, []
else
let scopes = IntMap.find (initial_vref + 1) !vrefs in
let scopes =
scopes |> List.map
(fun (name, value) ->
let vref = match value with
| Compound vref -> vref
| Leaf _ ->
incr vref_counter;
let vref = !vref_counter in
vrefs := IntMap.add vref ["", value] !vrefs;
vref
in
(name, vref)
)
in
!vrefs, scopes
let vrefs = ref IntMap.empty
(** JSON processing *)
(** Reading the request from the standard input *)
let read_json_DAP () =
let s = input_line stdin in
assert (Str.string_match (Str.regexp "Content-Length: \\([0-9]+\\)") s 0);
let content_length = int_of_string (Str.matched_group 1 s) in
let s = input_line stdin in
let s = if Str.string_match (Str.regexp "Content-Type:") s 0 then input_line stdin else s in
assert (s = "\r");
let obj_bytes = Bytes.create content_length in
let read_length = input stdin obj_bytes 0 content_length in
assert (read_length = content_length);
from_string @@ Bytes.to_string obj_bytes
(** Answering on stdin *)
let write_json_DAP obj =
let obj_str = pretty_to_string obj in
let obj_str_len = String.length obj_str in
let response = "Content-Length: " ^ (string_of_int obj_str_len) ^ "\r\n\r\n" ^ obj_str in
output_string stdout response;
flush stdout
(** Extraction functions for some JSON fields *)
let extract_command request = request |> member "command" |> to_string
let request = request |> member "seq" |> to_int
let request = request |> member "arguments" |> member "variablesReference" |> to_int
let request = request |> member "arguments" |> member "source" |> member "path" |> to_string
let request = request |> member "arguments" |> member "breakpoints" |> to_list
let bp = bp |> member "line" |> to_int
let x = x |> member "name" |> to_string
let request = request |> member "arguments" |> member "expression" |> to_string
let request = request |> member "arguments" |> member "file" |> to_string
let request = request |> member "arguments" |> member "line" |> to_int
let create_response request body :Yojson.Basic.t =
let command = extract_command request
and req_seq = extract_seq request
in
match body with
| `Null -> `Assoc [
("seq", `Int 0);
("type", `String "response");
("request_seq", `Int req_seq);
("success", `Bool true);
("command", `String command)
]
| _ -> `Assoc [
("seq", `Int 0);
("type", `String "response");
("request_seq", `Int req_seq);
("success", `Bool true);
("command", `String command);
("body", body)
]
let create_event name body :Yojson.Basic.t =
match body with
| `Null -> `Assoc [
("seq", `Int 0);
("type", `String "event");
("event", `String name);
]
| _ -> `Assoc [
("seq", `Int 0);
("type", `String "event");
("event", `String name);
("body", body)
]
let create_body_stopped reason :Yojson.Basic.t=
`Assoc [
("reason", `String reason);
("threadId", `Int 1)
]
let createFrame id name line column file path :Yojson.Basic.t=
`Assoc [
("id", `Int id);
("line", `Int line);
("column", `Int column);
("name", `String name);
("source",
`Assoc [
("name", `String file);
("path", `String path);
("sourceReference", `Int 0)
])
]
let createScope name vref :Yojson.Basic.t =
`Assoc [
("name", `String name);
("variablesReference", `Int vref);
("expensive", `Bool true);
]
let createVariable name = function
| Leaf value ->
`Assoc [
("name", `String name);
("value", `String value);
("variablesReference", `Int 0)
]
| Compound vref ->
`Assoc [
("name", `String name);
("value", `String "");
("variablesReference", `Int vref)
]
let body_initilize :Yojson.Basic.t =
`Assoc [
("supportsFunctionBreakpoints", `Bool true)
]
let body_threads :Yojson.Basic.t =
`Assoc [
("threads",
`List [
`Assoc [
("id", `Int 1);
("name",`String "thread 1")
]
])
]
let body_stackTrace stack_trace_json :Yojson.Basic.t =
`Assoc [
("totalFrames", `Int (List.length stack_trace_json));
("stackFrames", `List stack_trace_json)
]
let body_scopes scopes :Yojson.Basic.t =
`Assoc [
("scopes",
`List (
List.map (fun (name, vref) -> createScope name vref) scopes
)
)
]
let body_variables vars : Yojson.Basic.t =
`Assoc [
("variables", `List (List.map (fun (name, value) -> createVariable name value) vars))
]
let body_breakpoints nb_bps :Yojson.Basic.t=
`Assoc [
("breakpoints", `List (List.init nb_bps (fun _ -> `Assoc [("verified", `Bool true)])))
]
let body_empty_evaluate :Yojson.Basic.t=
`Assoc [
("result", `Null);
("variablesReference", `Int 0)
]
let body_evaluate vref :Yojson.Basic.t=
`Assoc [
("result", `Null);
("variablesReference", `Int vref)
]
let report_of_alarms alarms =
alarms |> List.fold_left
(fun report alarm -> add_alarm alarm report)
empty_report
let create_body_alarms_output alarms : Yojson.Basic.t =
`Assoc [
("category", `String "important");
("output", `String (Format.asprintf "%d new alarm%a" (List.length alarms) Debug.plurial_list alarms));
("data", `Assoc [
("kind", `String "alarms");
("alarms", `List (let _, _, r = Output.Json.render_alarms (report_of_alarms alarms) in r));
])
]
let create_body_environment_output file line env : Yojson.Basic.t =
`Assoc [
("category", `String "important");
("output", `Null);
("data", `Assoc [
("kind", `String "environment");
("file", `String file);
("line", `Int line);
("envrionment", env);
])
]
let last_request = ref `Null
(** Extract breakpoints from request *)
let breakpoints_from_request request =
let path = extract_path request
and breakpoints_json = extract_breakpoints request
in (path, List.map (function bp_json -> B_line (path, (extract_line_breakpoint bp_json))) breakpoints_json)
(** Extract functional breakpoints from request *)
let function_breakpoints_from_request request =
let breakpoints_json = extract_breakpoints request in
List.map (function bp_json -> B_function (extract_name bp_json)) breakpoints_json
(** Commands *)
type dap_command =
| Initialize
(** Initialize DA *)
| Launch
(** Launch DA *)
| Threads
(** Send list of current threads *)
| StackTrace
(** Send current stack trace *)
| Scopes
(** Send available scopes *)
| Vars of int (** variables reference *)
(** Send list of variables associated to the given variables reference*)
| Breaks of (string (** file *) * breakpoint list (** breakpoints *))
(** Set breakpoints for file *)
| FuncBreaks of breakpoint list
(** Set functional breakpoints *)
| ExceptBreaks
(** Set exceptional breakpoints *)
| Continue
(** Stop at next breakpoint *)
| Next
(** Stop at next statement and skip function calls *)
| Step
(** Step into function calls *)
| Finish
(** Finish current function *)
| Evaluate of string
| Environment of string * int
| Disconnect
(** The last entered command *)
let last_command = ref None
(** Read a command from input *)
let rec read_dap_command () =
let req = read_json_DAP () in
let cmd = extract_command req in
let c = match cmd with
| "initialize" -> Initialize
| "launch" -> Launch
| "setExceptionBreakpoints" -> ExceptBreaks
| "setFunctionBreakpoints" -> FuncBreaks (function_breakpoints_from_request req)
| "setBreakpoints" -> Breaks (breakpoints_from_request req)
| "threads" -> Threads
| "stackTrace" -> StackTrace
| "scopes" -> Scopes
| "variables" -> Vars (extract_varref req)
| "continue" -> Continue
| "next" -> Next
| "stepIn" -> Step
| "stepOut" -> Finish
| "evaluate" -> Evaluate (extract_expression req)
| "disconnect" -> Disconnect
| "environment" -> Environment (extract_file req, extract_line req)
| _ -> read_dap_command ()
in
last_request := req;
last_command := Some c;
c
let init () =
let cmd = try read_dap_command ()
with Exit -> exit 0
in
match cmd with
| Initialize ->
write_json_DAP (create_response !last_request body_initilize);
write_json_DAP (create_event "initialized" `Null)
| _ ->
assert false
let reach action man flow =
let range = action_range action in
if is_orig_range range then (
vrefs := IntMap.empty;
vref_counter := 0;
write_json_DAP (create_event "stopped" (create_body_stopped "step"));
)
let alarm alarms action man flow =
write_json_DAP (create_event "output" (create_body_alarms_output alarms))
let dummy_range = mk_fresh_range ()
let rec read_command action envdb man flow =
if not (is_orig_range (action_range action)) then
Interface.Step
else
let cmd = try read_dap_command ()
with Exit -> exit 0
in
match cmd with
| Initialize ->
assert false
| Launch ->
write_json_DAP (create_response !last_request `Null);
read_command action envdb man flow
| ExceptBreaks ->
write_json_DAP (create_response !last_request `Null);
read_command action envdb man flow
| Breaks breakpoints_info ->
let path = fst breakpoints_info in
let breakpoints_tmp =
BreakpointSet.filter
(fun b -> match b with
| B_function _-> true
| B_line (path2, _) -> not (path=path2)
| _ -> false
) !breakpoints
in
breakpoints := List.fold_left (fun set bp -> BreakpointSet.add bp set) breakpoints_tmp (snd breakpoints_info);
write_json_DAP (create_response !last_request (body_breakpoints (List.length (snd breakpoints_info))));
read_command action envdb man flow
| FuncBreaks breakpoints_info ->
let breakpoints_tmp =
BreakpointSet.filter
(function b ->
match b with
| B_function _-> false
| B_line _ -> true
| _ -> false
) !breakpoints in
breakpoints := List.fold_right (fun bp set -> BreakpointSet.add bp set) breakpoints_info breakpoints_tmp ;
write_json_DAP (create_response !last_request (body_breakpoints (List.length breakpoints_info)));
read_command action envdb man flow
| Threads ->
write_json_DAP (create_response !last_request body_threads);
read_command action envdb man flow
| StackTrace ->
let file_path_line_column_from_range range =
let pos = Location.get_range_start range in
let l = String.split_on_char '/' (Location.get_range_file range) in
let path = String.concat "/" l in
let path = if Filename.is_relative path then Sys.getcwd () ^ "/" ^ path else path in
let file = List.nth l ((List.length l) -1) in
(file,path,pos.pos_line,pos.pos_column)
in
let cs = Flow.get_callstack flow and i = ref 0 in
let call_stack_json =
List.map (function callsite ->
i := !i+1;
let (file,path,line,column) = file_path_line_column_from_range callsite.call_range
in createFrame !i (callsite.call_fun_orig_name) line column file path)
cs
in
let (file,path,line,column) = file_path_line_column_from_range (action_range action) in
let stack_trace_info = (createFrame 0 "Current pointer" line column file path)::call_stack_json in
write_json_DAP (create_response !last_request (body_stackTrace stack_trace_info));
read_command action envdb man flow
| Scopes ->
if is_orig_range (action_range action) then
let printer = Print.empty_printer () in
let vars = action_vars action in
List.iter
(fun v ->
try man.print_expr flow printer (mk_var v dummy_range)
with Not_found -> ()
) vars;
let pobj = get_printed_object printer in
let map, scopes = compute_scopes_vrefs pobj in
vrefs := IntMap.fold (fun vref v acc -> IntMap.add vref v acc) map !vrefs;
write_json_DAP (create_response !last_request (body_scopes scopes))
else
write_json_DAP (create_response !last_request (body_scopes []));
read_command action envdb man flow
| Vars vref ->
let children = IntMap.find vref !vrefs in
write_json_DAP (create_response !last_request (body_variables children));
read_command action envdb man flow
| Continue ->
write_json_DAP (create_response !last_request `Null );
Continue
| Next ->
write_json_DAP (create_response !last_request `Null);
Next
| Step ->
write_json_DAP (create_response !last_request `Null);
Step
| Finish ->
write_json_DAP (create_response !last_request `Null);
Finish
| Evaluate vars ->
let vars = String.split_on_char ' ' vars |>
List.map String.trim |>
List.filter (function "" -> false | _ -> true)
in
let vars =
List.fold_left
(fun acc s ->
let parts = String.split_on_char ',' s |>
List.filter (function "" -> false | _ -> true)
in
SetExt.StringSet.union acc (SetExt.StringSet.of_list parts)
) SetExt.StringSet.empty vars
in
let vars =
SetExt.StringSet.elements vars |> ListExt.map_filter
(fun name ->
try Some (find_var_by_name name man flow)
with Not_found -> None
)
in
let printer = Print.empty_printer () in
List.iter
(fun v ->
try man.print_expr flow printer (mk_var v dummy_range)
with Not_found -> ()
) vars;
let pobj = get_printed_object printer in
let initial_vref = !vref_counter in
let map = compute_vrefs pobj in
vrefs := IntMap.fold (fun vref v acc -> IntMap.add vref v acc) map !vrefs;
if IntMap.is_empty map then
write_json_DAP (create_response !last_request body_empty_evaluate)
else
write_json_DAP (create_response !last_request (body_evaluate (initial_vref + 1)));
read_command action envdb man flow
| Environment(file, line) ->
let envs, vars =
match find_envdb_opt file line envdb with
| None -> CallstackMap.empty, []
| Some(action, envs) ->
let vars = action_line_vars action in
envs, vars
in
let ctx = Flow.get_ctx flow in
let env =
CallstackMap.fold
(fun _ -> man.lattice.join ctx)
envs man.lattice.bottom
in
let flow' = Flow.singleton ctx T_cur env in
let printer = Print.empty_printer () in
vars |> List.iter
(fun v ->
try man.print_expr flow' printer (mk_var v dummy_range)
with Not_found -> ()
);
let body = print_object_to_json (get_printed_object printer) in
write_json_DAP (create_response !last_request body);
read_command action envdb man flow
| Disconnect ->
write_json_DAP (create_response !last_request `Null);
raise Exit
let rec wait_disconnect () =
let cmd =
try read_dap_command ()
with Exit -> exit 0
in
match cmd with
| Disconnect ->
write_json_DAP (create_response !last_request `Null);
exit 0
| _ -> wait_disconnect ()
let finish man flow =
write_json_DAP (create_event "terminated" `Null);
wait_disconnect ()
let error e =
write_json_DAP (create_event "output" (
`Assoc [
("category", `String "stderr");
("output", `String (Format.asprintf "Exception: %s" (Printexc.to_string e)))
]
));
wait_disconnect ()
end