diff --git a/CHANGELOG.md b/CHANGELOG.md index 29b27a6..1c01788 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,6 +5,16 @@ * Fix the empty "Globals" scope on OCaml >= 5.2 (#74). Globals are numbered by `Symtable.Global.t` rather than by `Ident.t` since 5.2, and reading the SYMB section with the old key type left the scope empty. +* Fix a crash when inspecting an array or other indexed value with a `variables` + request that omits the `filter` field. The spec says an omitted filter returns + both named and indexed children, however the adapter asserted there were no + indexed children and raised instead of returning them. Editors that page + variables send the filter and are unaffected (VS Code, and emacs dap-mode), + but nvim-dap has no variable paging and sends only `variablesReference`, so + expanding an array in nvim-dap crashed the adapter. +* Report a clear error when `program` is a native executable or other + non-bytecode file (#33). Loading such a file failed with `Bad magic`; it now + explains that earlybird debugs bytecode and to point `program` at a `.bc`. ### Added diff --git a/src/adapter/inspect.ml b/src/adapter/inspect.ml index 1c9f048..0dc4abd 100644 --- a/src/adapter/inspect.ml +++ b/src/adapter/inspect.ml @@ -109,25 +109,28 @@ let run ~init_args ~launch_args ~dbg rpc = let%lwt variables = match Hashtbl.find_opt value_tbl arg.variables_reference with | None -> Lwt.return [] - | Some value -> ( + | Some value -> + let indexed ?(start = 0) ?count () = + let end_ = + (match count with + | Some count -> start + count + | None -> value#num_indexed) + - 1 + in + Seq.int_range ~start ~end_ () + |> List.of_seq + |> Lwt_list.map_s (fun i -> + let%lwt obj = value#get_indexed i in + Lwt.return (string_of_int i, obj)) + in + (* An omitted filter means fetch both named and indexed children. *) match arg.filter with | None -> - assert (value#num_indexed = 0); - value#list_named + let%lwt named = value#list_named in + let%lwt indexed = indexed () in + Lwt.return (named @ indexed) | Some Named -> value#list_named - | Some Indexed -> - let start = arg.start |> Option.value ~default:0 in - let end_ = - (match arg.count with - | Some count -> start + count - | None -> value#num_indexed) - - 1 - in - Seq.int_range ~start ~end_ () - |> List.of_seq - |> Lwt_list.map_s (fun i -> - let%lwt obj = value#get_indexed i in - Lwt.return (string_of_int i, obj))) + | Some Indexed -> indexed ?start:arg.start ?count:arg.count () in let variables = variables diff --git a/src/debugger/core/symbols/bytecode.ml b/src/debugger/core/symbols/bytecode.ml index f1112ba..9ff6788 100644 --- a/src/debugger/core/symbols/bytecode.ml +++ b/src/debugger/core/symbols/bytecode.ml @@ -3,6 +3,15 @@ open Instruct type debug_info = (Instruct.debug_event list * string list) list +(* Raised when [load_debuginfo] is pointed at a file that is not an OCaml + bytecode executable (most often a native executable). *) +exception Not_ocaml_bytecode of string + +let () = + Printexc.register_printer (function + | Not_ocaml_bytecode message -> Some message + | _ -> None) + let seek_section (pos, section_table) name = let rec seek_sec pos = function | [] -> raise Not_found @@ -58,7 +67,14 @@ let load_debuginfo file = Lwt_io.read_string_exactly ic (String.length Config.exec_magic_number) in if%lwt Lwt.return (magic <> Config.exec_magic_number) then - Lwt.fail_invalid_arg "Bad magic";%lwt + Lwt.fail + (Not_ocaml_bytecode + (Printf.sprintf + "%s is not an OCaml bytecode executable. earlybird debugs \ + bytecode programs, not native executables. Compile with \ + `ocamlc -g` or a dune `(modes byte)` target and set \"program\" \ + to the resulting .bc file." + file));%lwt let pos_toc = Int64.sub pos_trailer (Int64.of_int (8 * num_sections)) in Lwt_io.set_position ic pos_toc;%lwt let section_table = ref [] in diff --git a/src/debugger/debugger.ml b/src/debugger/debugger.ml index aa7085b..7b89e18 100644 --- a/src/debugger/debugger.ml +++ b/src/debugger/debugger.ml @@ -5,6 +5,14 @@ open Frame module PcSet_ = Set.Make (Ordered_type.Make_tuple2 (Int) (Int)) module IntMap_ = Map.Make (Int) +(* The symbol table, re-exported so that it can be exercised on its own. Mapping + a source line to a debug event is subtle enough to be worth testing directly, + without a debuggee in the way. *) +module Bytecode = Bytecode +module Code_fragment = Code_fragment +module Code_module = Code_module +module Symbols = Symbols + type pc = int * int type 'a source_location = 'a Debug_types.source_location = { diff --git a/test/dap_client.ml b/test/dap_client.ml index 808b881..11262fe 100644 --- a/test/dap_client.ml +++ b/test/dap_client.ml @@ -141,6 +141,94 @@ let scopes t ~(frame : Stack_frame.t) = in Lwt.return (scope.name, variables)) +let scope t ~frame ~name = + let%lwt scopes = scopes t ~frame in + match List.assoc_opt name scopes with + | Some variables -> Lwt.return variables + | None -> Lwt.fail_with (Printf.sprintf "no %s scope" name) + +(* One level of children of a structured value (the elements of a list, the + fields of a record, ...). + + Values expose named children (record fields, closure captures) and indexed + children (array and list elements) separately, and the adapter expects them + to be fetched separately, with a filter, the way VS Code does when a value + reports both counts. *) +let expand t ~(variable : Variable.t) = + let open Variables_command.Arguments in + let reference = variable.variables_reference in + let vars args = + let%lwt res = Debug_rpc.exec_command t.rpc (module Variables_command) args in + Lwt.return res.Variables_command.Result.variables + in + let named = Option.value variable.named_variables ~default:0 in + let indexed = Option.value variable.indexed_variables ~default:0 in + if reference = 0 then Lwt.return [] + else if named = 0 && indexed = 0 then + (* Counts unknown; a single unfiltered request returns everything. *) + vars (make ~variables_reference:reference ()) + else + let%lwt named = + if named > 0 then + vars (make ~variables_reference:reference ~filter:(Some Filter.Named) ()) + else Lwt.return [] + in + let%lwt indexed = + if indexed > 0 then + vars + (make ~variables_reference:reference ~filter:(Some Filter.Indexed) + ~start:(Some 0) ~count:(Some indexed) ()) + else Lwt.return [] + in + Lwt.return (named @ indexed) + +(* Children of a value fetched in a single request with no filter. The DAP spec + says an omitted filter returns both named and indexed children. *) +let children_unfiltered t ~(variable : Variable.t) = + if variable.variables_reference = 0 then Lwt.return [] + else + let%lwt res = + Debug_rpc.exec_command t.rpc + (module Variables_command) + Variables_command.Arguments.( + make ~variables_reference:variable.variables_reference ()) + in + Lwt.return res.Variables_command.Result.variables + +(* Stepping. Each returns the frame the debuggee comes to rest in. *) + +let step t ~thread_id command = + let%lwt () = command () in + let%lwt _ = wait_stopped t in + top_frame t ~thread_id + +let next t ~thread_id = + step t ~thread_id (fun () -> + Debug_rpc.exec_command t.rpc + (module Next_command) + Next_command.Arguments.(make ~thread_id ())) + +let step_in t ~thread_id = + step t ~thread_id (fun () -> + Debug_rpc.exec_command t.rpc + (module Step_in_command) + Step_in_command.Arguments.(make ~thread_id ())) + +let step_out t ~thread_id = + step t ~thread_id (fun () -> + Debug_rpc.exec_command t.rpc + (module Step_out_command) + Step_out_command.Arguments.(make ~thread_id ())) + +let continue t ~thread_id = + step t ~thread_id (fun () -> + let%lwt _ = + Debug_rpc.exec_command t.rpc + (module Continue_command) + Continue_command.Arguments.(make ~thread_id ()) + in + Lwt.return ()) + let string_of_reason (reason : Stopped_event.Payload.Reason.t) = match reason with | Breakpoint -> "breakpoint" diff --git a/test/dune b/test/dune index 16430da..d6f0e78 100644 --- a/test/dune +++ b/test/dune @@ -1,7 +1,12 @@ -; Integration tests. Each test runs the real debug adapter against the bytecode -; program in fixtures/, drives it over the debug adapter protocol just like an -; editor would, and diffs the transcript it prints against a recorded .expected -; file. Adding a test means adding a scenario module plus the two rules below. +; Integration tests. Most run the real debug adapter against a bytecode program +; in fixtures/, drive it over the debug adapter protocol just like an editor +; would, and diff the transcript the scenario prints against a recorded +; .expected file. test_events is different: it links against the debugger +; library and exercises the symbol table directly. +; +; Adding a protocol-driven test means adding a scenario module to the +; (executables) below and a pair of rules (run -> .actual, then diff) like the +; ones here. (library (name dap_client) @@ -11,12 +16,14 @@ (libraries dap.types dap.rpc_lwt lwt lwt.unix lwt_react)) (executables - (names test_scopes test_frames) - (modules test_scopes test_frames) + (names test_scopes test_frames test_stepping test_values test_heap test_indexed) + (modules test_scopes test_frames test_stepping test_values test_heap test_indexed) (preprocess (pps lwt_ppx)) (libraries dap.types dap_client lwt lwt.unix)) +; --- protocol-driven scenarios --------------------------------------------- + (rule (targets test_scopes.actual) (deps @@ -25,12 +32,8 @@ fixtures/hello.bc fixtures/hello.ml) (action - (setenv - EARLYBIRD_ADAPTER - %{adapter} - (with-stdout-to - %{targets} - (run %{driver}))))) + (setenv EARLYBIRD_ADAPTER %{adapter} + (with-stdout-to %{targets} (run %{driver}))))) (rule (alias runtest) @@ -45,14 +48,110 @@ fixtures/hello.bc fixtures/hello.ml) (action - (setenv - EARLYBIRD_ADAPTER - %{adapter} - (with-stdout-to - %{targets} - (run %{driver}))))) + (setenv EARLYBIRD_ADAPTER %{adapter} + (with-stdout-to %{targets} (run %{driver}))))) (rule (alias runtest) (action (diff test_frames.expected test_frames.actual))) + +(rule + (targets test_stepping.actual) + (deps + (:driver test_stepping.exe) + (:adapter %{exe:../src/main/main.exe}) + fixtures/hello.bc + fixtures/hello.ml) + (action + (setenv EARLYBIRD_ADAPTER %{adapter} + (with-stdout-to %{targets} (run %{driver}))))) + +(rule + (alias runtest) + (action + (diff test_stepping.expected test_stepping.actual))) + +(rule + (targets test_values.actual) + (deps + (:driver test_values.exe) + (:adapter %{exe:../src/main/main.exe}) + fixtures/values.bc + fixtures/values.ml) + (action + (setenv EARLYBIRD_ADAPTER %{adapter} + (with-stdout-to %{targets} (run %{driver}))))) + +(rule + (alias runtest) + (action + (diff test_values.expected test_values.actual))) + +(rule + (targets test_heap.actual) + (deps + (:driver test_heap.exe) + (:adapter %{exe:../src/main/main.exe}) + fixtures/closure.bc + fixtures/closure.ml) + (action + (setenv EARLYBIRD_ADAPTER %{adapter} + (with-stdout-to %{targets} (run %{driver}))))) + +(rule + (alias runtest) + (action + (diff test_heap.expected test_heap.actual))) + +(rule + (targets test_indexed.actual) + (deps + (:driver test_indexed.exe) + (:adapter %{exe:../src/main/main.exe}) + fixtures/values.bc + fixtures/values.ml) + (action + (setenv EARLYBIRD_ADAPTER %{adapter} + (with-stdout-to %{targets} (run %{driver}))))) + +(rule + (alias runtest) + (action + (diff test_indexed.expected test_indexed.actual))) + +; --- symbol table, exercised directly -------------------------------------- + +(executables + (names test_events test_bad_magic) + (modules test_events test_bad_magic) + (preprocess + (pps lwt_ppx)) + (libraries debugger lwt lwt.unix)) + +(rule + (targets test_events.actual) + (deps + (:driver test_events.exe) + fixtures/hello.bc + fixtures/hello.ml) + (action + (with-stdout-to %{targets} (run %{driver})))) + +(rule + (alias runtest) + (action + (diff test_events.expected test_events.actual))) + +(rule + (targets test_bad_magic.actual) + (deps + (:driver test_bad_magic.exe) + fixtures/not_bytecode.txt) + (action + (with-stdout-to %{targets} (run %{driver})))) + +(rule + (alias runtest) + (action + (diff test_bad_magic.expected test_bad_magic.actual))) diff --git a/test/fixtures/closure.ml b/test/fixtures/closure.ml new file mode 100644 index 0000000..e7fb26a --- /dev/null +++ b/test/fixtures/closure.ml @@ -0,0 +1,19 @@ +(* Fixture for the Heap scope test: [bump] captures [count] and [step] from its + enclosing scope, so they live in the closure's environment (the Heap scope) + rather than on the stack. Keep the line numbers stable as the tests set + breakpoints by line. *) + +let make_counter start step = + let count = ref start in + let bump () = + let bumped = !count + step in + count := bumped; + bumped + in + bump + +let () = + let bump = make_counter 10 5 in + let first = bump () in + let second = bump () in + print_endline (string_of_int (first + second)) diff --git a/test/fixtures/dune b/test/fixtures/dune index 9b2595d..93af568 100644 --- a/test/fixtures/dune +++ b/test/fixtures/dune @@ -8,3 +8,15 @@ (deps hello.ml) (action (run %{bin:ocamlc} -g hello.ml -o hello.bc))) + +(rule + (targets values.bc) + (deps values.ml) + (action + (run %{bin:ocamlc} -g values.ml -o values.bc))) + +(rule + (targets closure.bc) + (deps closure.ml) + (action + (run %{bin:ocamlc} -g closure.ml -o closure.bc))) diff --git a/test/fixtures/not_bytecode.txt b/test/fixtures/not_bytecode.txt new file mode 100644 index 0000000..cae4ef3 --- /dev/null +++ b/test/fixtures/not_bytecode.txt @@ -0,0 +1,3 @@ +This file stands in for a native executable (or any non-bytecode file) passed to +the debugger. It is deliberately not an OCaml bytecode executable, so loading its +debug info fails. See test_bad_magic.ml. diff --git a/test/fixtures/values.ml b/test/fixtures/values.ml new file mode 100644 index 0000000..4435693 --- /dev/null +++ b/test/fixtures/values.ml @@ -0,0 +1,34 @@ +(* Fixture for the value rendering test: one local per shape of OCaml value the + adapter knows how to render. Keep the line numbers stable as the tests set + breakpoints by line. + + Every local is referenced at the end so none can be dropped as unused, which + would otherwise make the set of visible locals depend on the compiler. *) + +type person = { name : string; age : int } +type shape = Circle of float | Square of int | Point + +let () = + let int_ = 42 in + let float_ = 1.5 in + let string_ = "hi" in + let char_ = 'x' in + let bool_ = true in + let unit_ = () in + let int64_ = 9L in + let list_ = [ 1; 2; 3 ] in + let array_ = [| 4; 5 |] in + let tuple_ = (1, "two") in + let option_ = Some 7 in + let none_ = (None : int option) in + let record_ = { name = "bob"; age = 30 } in + let variant_ = Circle 2.5 in + let constant_ = Point in + let square_ = Square 3 in + let closure_ = fun n -> n + int_ in + let lazy_ = lazy (int_ + 1) in + ignore + ( int_, float_, string_, char_, bool_, unit_, int64_, list_, array_, tuple_, + option_, none_, record_, variant_, constant_, square_, closure_ 1, + Lazy.force lazy_ ); + print_endline "done" diff --git a/test/test_bad_magic.expected b/test/test_bad_magic.expected new file mode 100644 index 0000000..d2806fb --- /dev/null +++ b/test/test_bad_magic.expected @@ -0,0 +1 @@ +fixtures/not_bytecode.txt is not an OCaml bytecode executable. earlybird debugs bytecode programs, not native executables. Compile with `ocamlc -g` or a dune `(modes byte)` target and set "program" to the resulting .bc file. diff --git a/test/test_bad_magic.ml b/test/test_bad_magic.ml new file mode 100644 index 0000000..df19c0b --- /dev/null +++ b/test/test_bad_magic.ml @@ -0,0 +1,15 @@ +(* Loading a file that is not an OCaml bytecode executable (e.g. a native + executable, the mistake behind issue #33) should fail with a message that + says so and points at the .bc, rather than "Bad magic". *) + +open Debugger + +let () = + Lwt_main.run + (try%lwt + let%lwt _ = Bytecode.load_debuginfo "fixtures/not_bytecode.txt" in + print_endline "expected loading to fail, but it succeeded"; + Lwt.return () + with exn -> + print_endline (Printexc.to_string exn); + Lwt.return ()) diff --git a/test/test_events.expected b/test/test_events.expected new file mode 100644 index 0000000..67c5188 --- /dev/null +++ b/test/test_events.expected @@ -0,0 +1,13 @@ + 1 snaps to none contains [] | (* Fixture program debugged by the integration tests. Keep the line numbers + 2 snaps to none contains [] | stable as the tests set breakpoints by line. *) + 3 snaps to none contains [] | + 4 snaps to none contains [] | let greet name = + 5 snaps to 5:3 contains [] | let greeting = "Hello, " ^ name in + 6 snaps to 6:3 contains [6:3] | greeting + 7 snaps to none contains [] | + 8 snaps to none contains [] | let () = + 9 snaps to none contains [] | let x = 41 in +10 snaps to 10:3 contains [10:3; 11:3] | let y = x + 1 in +11 snaps to 11:3 contains [] | let msg = greet "world" in +12 snaps to 12:3 contains [12:3; 12:3] | print_endline msg; +13 snaps to 12:3 contains [] | print_endline (string_of_int y) diff --git a/test/test_events.ml b/test/test_events.ml new file mode 100644 index 0000000..f31275a --- /dev/null +++ b/test/test_events.ml @@ -0,0 +1,72 @@ +(* Map source lines to debug events, the way setting a breakpoint does. + + Code_module.find_event snaps a requested line to a nearby debug event as long + as only whitespace and comments separate the two (Trivia_check), while + find_events returns the events that fall within the line itself. Between them + they decide which lines a breakpoint can be set on, and where it ends up. + + This is exercised directly on the symbol table, without running a debuggee, + so a failure points at the mapping rather than at the adapter. *) + +open Debugger + +(* [In_channel] was only added in OCaml 4.14. Read the file the old way so the + tests build on 4.12/4.13. Remove once when pre-4.14 versions are dropped. *) +let read_file path = + let ic = open_in_bin path in + Fun.protect + ~finally:(fun () -> close_in ic) + (fun () -> really_input_string ic (in_channel_length ic)) + +let module_of_bytecode ~program ~module_id = + let%lwt debug_info = Bytecode.load_debuginfo program in + let frag = Code_fragment.make 0 debug_info in + (* Resolving the fragment reads the sources, which find_event needs to know + where the lines of the module start. *) + let symbols = Symbols.create () in + Symbols.add_fragment symbols frag;%lwt + Lwt.return (Code_fragment.find_module frag module_id) + +let position (event : Instruct.debug_event) = + let pos = event.ev_loc.loc_start in + (pos.pos_lnum, pos.pos_cnum - pos.pos_bol + 1) + +let main () = + let%lwt module_ = + module_of_bytecode ~program:"fixtures/hello.bc" ~module_id:"Hello" + in + let source = read_file "fixtures/hello.ml" in + (* Drop the empty string after the file's trailing newline so we only query + lines that actually exist. *) + let lines = + match List.rev (String.split_on_char '\n' source) with + | "" :: rest -> List.rev rest + | _ -> String.split_on_char '\n' source + in + let describe f = + match f () with + | events -> + events + |> List.map (fun event -> + let line, column = position event in + Printf.sprintf "%d:%d" line column) + | exception Not_found -> [] + in + lines + |> List.iteri (fun i line -> + let line_no = i + 1 in + (* Where a breakpoint on this line would end up ... *) + let event = + match describe (fun () -> [ Code_module.find_event module_ ~line:line_no () ]) with + | [] -> "none" + | positions -> String.concat "; " positions + in + (* ... and the events the line itself contains. *) + let within = + describe (fun () -> Code_module.find_events module_ ~line:line_no ()) + in + Printf.printf "%2d snaps to %-6s contains [%s] | %s\n" line_no event + (String.concat "; " within) line); + Lwt.return () + +let () = Lwt_main.run (main ()) diff --git a/test/test_heap.expected b/test/test_heap.expected new file mode 100644 index 0000000..c1f2875 --- /dev/null +++ b/test/test_heap.expected @@ -0,0 +1,4 @@ +stopped in Closure.make_counter.bump:9 +Stack: +Heap: step = 5, count = {…} + count.contents = 10 diff --git a/test/test_heap.ml b/test/test_heap.ml new file mode 100644 index 0000000..7dc12f0 --- /dev/null +++ b/test/test_heap.ml @@ -0,0 +1,44 @@ +(* Stop inside a closure and look at the Heap scope, which holds the variables + the closure captured from its enclosing scope rather than the ones on its own + stack. + + This is the scope read by Value_scope.iter_compenv_heap, whose shape changed + with the compiler (Instruct.compilation_env grew a ce_closure field), so it + is version-sensitive in the same way the Globals scope was in #74. *) + +open Debug_protocol + +let print_scope name variables = + let variables = + variables + |> List.map (fun (variable : Variable.t) -> + Printf.sprintf "%s = %s" variable.name variable.value) + in + match variables with + | [] -> Printf.printf "%s: \n" name + | variables -> Printf.printf "%s: %s\n" name (String.concat ", " variables) + +let main () = + (* Line 9 is [let bumped = !count + step in], inside [bump]: [count] and + [step] are captured, [bumped] is local. *) + Dap_client.with_session ~program:"fixtures/closure.bc" + ~source:"fixtures/closure.ml" ~breakpoints:[ 9 ] (fun t -> + let%lwt stopped = Dap_client.wait_stopped t in + let thread_id = Option.value stopped.thread_id ~default:0 in + let%lwt frame = Dap_client.top_frame t ~thread_id in + Printf.printf "stopped in %s:%d\n" frame.name frame.line; + let%lwt stack = Dap_client.scope t ~frame ~name:"Stack" in + print_scope "Stack" stack; + let%lwt heap = Dap_client.scope t ~frame ~name:"Heap" in + print_scope "Heap" heap; + (* [count] is a ref, so it expands to its contents. *) + heap + |> Lwt_list.iter_s (fun (variable : Variable.t) -> + let%lwt children = Dap_client.expand t ~variable in + children + |> List.iter (fun (child : Variable.t) -> + Printf.printf " %s.%s = %s\n" variable.name child.name + child.value); + Lwt.return ())) + +let () = Lwt_main.run (main ()) diff --git a/test/test_indexed.expected b/test/test_indexed.expected new file mode 100644 index 0000000..4bc619a --- /dev/null +++ b/test/test_indexed.expected @@ -0,0 +1,3 @@ +list_ (:: (‹1›, ‹2›)) -> ‹1› = 1, ‹2› = :: (‹1›, ‹2›) +array_ ([|…|]) -> ‹length› = 2, 0 = 4, 1 = 5 +record_ ({…}) -> name = "bob", age = 30 diff --git a/test/test_indexed.ml b/test/test_indexed.ml new file mode 100644 index 0000000..84b6309 --- /dev/null +++ b/test/test_indexed.ml @@ -0,0 +1,35 @@ +(* Expand collections with a single, unfiltered [variables] request — the way a + minimal DAP client that does not read the named/indexed child counts does. + + The DAP spec says an omitted filter returns both named and indexed children. + This checks the unfiltered path returns the children for a value with named + children (a list), indexed children (an array), and both (the adapter exposes + an array's length as a named child). *) + +open Debug_protocol + +let main () = + Dap_client.with_session ~program:"fixtures/values.bc" + ~source:"fixtures/values.ml" ~breakpoints:[ 34 ] (fun t -> + let%lwt stopped = Dap_client.wait_stopped t in + let thread_id = Option.value stopped.thread_id ~default:0 in + let%lwt frame = Dap_client.top_frame t ~thread_id in + let%lwt locals = Dap_client.scope t ~frame ~name:"Stack" in + [ "list_"; "array_"; "record_" ] + |> Lwt_list.iter_s (fun name -> + match + List.find_opt (fun (v : Variable.t) -> v.name = name) locals + with + | None -> Lwt.fail_with (Printf.sprintf "no local %s" name) + | Some variable -> + let%lwt children = Dap_client.children_unfiltered t ~variable in + let children = + children + |> List.map (fun (c : Variable.t) -> + Printf.sprintf "%s = %s" c.name c.value) + in + Printf.printf "%s (%s) -> %s\n" name variable.value + (String.concat ", " children); + Lwt.return ())) + +let () = Lwt_main.run (main ()) diff --git a/test/test_stepping.expected b/test/test_stepping.expected new file mode 100644 index 0000000..b26cd70 --- /dev/null +++ b/test/test_stepping.expected @@ -0,0 +1,4 @@ +breakpoint -> Hello:10 (depth 1) +next -> Hello:11 (depth 1) +step in -> Hello.greet:5 (depth 2) +step out -> Hello:11 (depth 1) diff --git a/test/test_stepping.ml b/test/test_stepping.ml new file mode 100644 index 0000000..b27e8c6 --- /dev/null +++ b/test/test_stepping.ml @@ -0,0 +1,34 @@ +(* Walk through the fixture with the stepping commands and record where the + debuggee comes to rest each time. + + The interesting, stable signal is the shape of the walk: [next] stays in the + current function, [step in] descends into the callee (one more frame), [step + out] returns to the caller (one fewer). Exact landing lines are printed too, + but those are the compiler's to decide. *) + +open Debug_protocol + +let report t ~thread_id label = + let%lwt frames = Dap_client.stack_trace t ~thread_id in + let depth = List.length frames in + let top = List.hd frames in + Printf.printf "%-9s -> %s:%d (depth %d)\n" label top.Stack_frame.name + top.line depth; + Lwt.return () + +let main () = + (* Line 10 is [let y = x + 1 in]; line 11 the call to [greet]. *) + Dap_client.with_session ~program:"fixtures/hello.bc" + ~source:"fixtures/hello.ml" ~breakpoints:[ 10 ] (fun t -> + let%lwt stopped = Dap_client.wait_stopped t in + let thread_id = Option.value stopped.thread_id ~default:0 in + let%lwt () = report t ~thread_id "breakpoint" in + let%lwt _ = Dap_client.next t ~thread_id in + let%lwt () = report t ~thread_id "next" in + let%lwt _ = Dap_client.step_in t ~thread_id in + let%lwt () = report t ~thread_id "step in" in + let%lwt _ = Dap_client.step_out t ~thread_id in + let%lwt () = report t ~thread_id "step out" in + Lwt.return ()) + +let () = Lwt_main.run (main ()) diff --git a/test/test_values.expected b/test/test_values.expected new file mode 100644 index 0000000..b143a4e --- /dev/null +++ b/test/test_values.expected @@ -0,0 +1,32 @@ +int_ = 42 +float_ = 1.5 +string_ = "hi" +char_ = 'x' +bool_ = true +unit_ = () +int64_ = 9 +list_ = :: (‹1›, ‹2›) + ‹1› = 1 + ‹2› = :: (‹1›, ‹2›) +array_ = [|…|] + ‹length› = 2 + 0 = 4 + 1 = 5 +tuple_ = (‹1›, ‹2›) + ‹1› = 1 + ‹2› = "two" +option_ = Some ‹1› + ‹1› = 7 +none_ = None +record_ = {…} + name = "bob" + age = 30 +variant_ = Circle ‹1› + ‹1› = 2.5 +constant_ = Point +square_ = Square ‹1› + ‹1› = 3 +closure_ = «fun» + ‹tips› = … +lazy_ = «lazy.is_val» + ‹val› = 43 diff --git a/test/test_values.ml b/test/test_values.ml new file mode 100644 index 0000000..cff854f --- /dev/null +++ b/test/test_values.ml @@ -0,0 +1,26 @@ +(* Render one local per shape of OCaml value, and expand the structured ones a + level to check their children. This covers the value_* renderers: ints, + floats, chars, strings, bools, unit, boxed ints, lists, arrays, tuples, + variants, records, closures and lazies. *) + +open Debug_protocol + +let main () = + (* Line 34 is the [print_endline] at the end, by which point every local is + bound. *) + Dap_client.with_session ~program:"fixtures/values.bc" + ~source:"fixtures/values.ml" ~breakpoints:[ 34 ] (fun t -> + let%lwt stopped = Dap_client.wait_stopped t in + let thread_id = Option.value stopped.thread_id ~default:0 in + let%lwt frame = Dap_client.top_frame t ~thread_id in + let%lwt variables = Dap_client.scope t ~frame ~name:"Stack" in + variables + |> Lwt_list.iter_s (fun (variable : Variable.t) -> + Printf.printf "%-10s = %s\n" variable.name variable.value; + let%lwt children = Dap_client.expand t ~variable in + children + |> List.iter (fun (child : Variable.t) -> + Printf.printf " %s = %s\n" child.name child.value); + Lwt.return ())) + +let () = Lwt_main.run (main ())