From f350526d41a900b8860c4c0a78ebae5d23522dff Mon Sep 17 00:00:00 2001 From: Tim McGilchrist Date: Wed, 15 Jul 2026 14:46:30 +1000 Subject: [PATCH 1/3] Extend integration tests: stepping, values, heap scope, event mapping Add four scenarios on top of the existing scopes/frames tests: - test_stepping drives next/stepIn/stepOut and records where the debuggee lands, using stack depth as the stable signal so the test does not depend on exactly which line each step snaps to. - test_values renders one local per shape of value (ints, floats, chars, strings, bools, unit, boxed ints, lists, arrays, tuples, options, records, variants, closures, lazies) and expands the structured ones a level. The fixture references every local so none is dropped as unused. - test_heap stops inside a closure and reads the Heap scope, i.e. the variables captured from the enclosing scope. This exercises Value_scope.iter_compenv_heap, which is version-conditional in the same way the Globals scope was in #74. - test_events exercises Code_module.find_event/find_events directly, without a debuggee, and records how each source line maps to a debug event. It documents the current mapping, including the lines that are not breakpointable and the backward snap noted in KNOWN_ISSUES.md. The dap_client helper gains stepping commands and value expansion that fetches named and indexed children separately, with a filter, the way an editor does. debugger.ml re-exports the symbol-table modules so the event-mapping test can reach them. --- src/debugger/debugger.ml | 8 +++ test/dap_client.ml | 75 +++++++++++++++++++++++++ test/dune | 106 ++++++++++++++++++++++++++++++------ test/fixtures/closure.ml | 19 +++++++ test/fixtures/dune | 12 ++++ test/fixtures/values.ml | 34 ++++++++++++ test/test_events.expected | 13 +++++ test/test_events.ml | 64 ++++++++++++++++++++++ test/test_heap.expected | 4 ++ test/test_heap.ml | 44 +++++++++++++++ test/test_stepping.expected | 4 ++ test/test_stepping.ml | 34 ++++++++++++ test/test_values.expected | 32 +++++++++++ test/test_values.ml | 26 +++++++++ 14 files changed, 457 insertions(+), 18 deletions(-) create mode 100644 test/fixtures/closure.ml create mode 100644 test/fixtures/values.ml create mode 100644 test/test_events.expected create mode 100644 test/test_events.ml create mode 100644 test/test_heap.expected create mode 100644 test/test_heap.ml create mode 100644 test/test_stepping.expected create mode 100644 test/test_stepping.ml create mode 100644 test/test_values.expected create mode 100644 test/test_values.ml 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..2367d55 100644 --- a/test/dap_client.ml +++ b/test/dap_client.ml @@ -141,6 +141,81 @@ 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) + +(* 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..f568f09 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) + (modules test_scopes test_frames test_stepping test_values test_heap) (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,81 @@ 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))) + +; --- symbol table, exercised directly -------------------------------------- + +(executable + (name test_events) + (modules test_events) + (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))) 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/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_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..681a62f --- /dev/null +++ b/test/test_events.ml @@ -0,0 +1,64 @@ +(* 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 + +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 = In_channel.with_open_text "fixtures/hello.ml" In_channel.input_all 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_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 ()) From 172eb7244a641a84c2a52eb34b5dad0664de87c9 Mon Sep 17 00:00:00 2001 From: Tim McGilchrist Date: Wed, 15 Jul 2026 19:57:48 +1000 Subject: [PATCH 2/3] Fix crash inspecting indexed values with an unfiltered variables request The variables request handler asserted that a value had no indexed children when the request omitted the filter field, and raised Assert_failure for an array. The DAP spec says an omitted filter returns both named and indexed children, so this is a valid request. --- CHANGELOG.md | 7 +++++++ src/adapter/inspect.ml | 35 +++++++++++++++++++---------------- test/dap_client.ml | 13 +++++++++++++ test/dune | 20 ++++++++++++++++++-- test/test_indexed.expected | 3 +++ test/test_indexed.ml | 35 +++++++++++++++++++++++++++++++++++ 6 files changed, 95 insertions(+), 18 deletions(-) create mode 100644 test/test_indexed.expected create mode 100644 test/test_indexed.ml diff --git a/CHANGELOG.md b/CHANGELOG.md index 29b27a6..6e527e0 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,6 +5,13 @@ * 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. ### 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/test/dap_client.ml b/test/dap_client.ml index 2367d55..11262fe 100644 --- a/test/dap_client.ml +++ b/test/dap_client.ml @@ -182,6 +182,19 @@ let expand t ~(variable : Variable.t) = 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 = diff --git a/test/dune b/test/dune index f568f09..9dccf21 100644 --- a/test/dune +++ b/test/dune @@ -16,8 +16,8 @@ (libraries dap.types dap.rpc_lwt lwt lwt.unix lwt_react)) (executables - (names test_scopes test_frames test_stepping test_values test_heap) - (modules test_scopes test_frames test_stepping test_values test_heap) + (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)) @@ -104,6 +104,22 @@ (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 -------------------------------------- (executable 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 ()) From 875d1db515eaaccc4adfd31930663dda597496c2 Mon Sep 17 00:00:00 2001 From: Tim McGilchrist Date: Sun, 19 Jul 2026 11:53:12 +1000 Subject: [PATCH 3/3] Resolve dune >= 3.0 sources by mapping /workspace_root Since dune 3.0, map_workspace_root is on by default and rewrites the build directory in a bytecode's debug info to a fixed "/workspace_root", which does not exist on disk. The adapter could not find a module's source there, so it was never registered, and since breakpoints are matched to a module by the source file's digest, no breakpoint in a dune-built module could bind. Derive the real directories "/workspace_root" stands for from the executable's path (the source root and the build context, which both hold the sources), and rewrite the recorded search dirs with them before resolving. Paths without the prefix, and executables not under a _build directory, are left unchanged, so non-dune builds are unaffected. Add test_workspace (unit test of the path logic) and test_dune_source (an integration test that reproduces dune's /workspace_root debug info with BUILD_PATH_PREFIX_MAP and checks a breakpoint binds). Fixes #58, #11, #20, #47, #57 --- CHANGELOG.md | 6 +++ src/debugger/core/controller.ml | 3 +- src/debugger/core/symbols/symbols.ml | 64 +++++++++++++++++++++++++++- test/dune | 40 ++++++++++++++--- test/fixtures/dune | 10 +++++ test/fixtures/make_wsroot_bc.sh | 33 ++++++++++++++ test/fixtures/wsroot.ml | 4 ++ test/test_dune_source.expected | 4 ++ test/test_dune_source.ml | 26 +++++++++++ test/test_workspace.expected | 22 ++++++++++ test/test_workspace.ml | 45 +++++++++++++++++++ 11 files changed, 249 insertions(+), 8 deletions(-) create mode 100644 test/fixtures/make_wsroot_bc.sh create mode 100644 test/fixtures/wsroot.ml create mode 100644 test/test_dune_source.expected create mode 100644 test/test_dune_source.ml create mode 100644 test/test_workspace.expected create mode 100644 test/test_workspace.ml diff --git a/CHANGELOG.md b/CHANGELOG.md index 6e527e0..35d60f0 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -12,6 +12,12 @@ 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. +* Resolve sources and bind breakpoints for executables built by dune >= 3.0 + (#58, #11, #20, #47, #57). Since dune 3.0, `map_workspace_root` is on by + default and rewrites the build directory in the debug info to a fixed + `/workspace_root`, which does not exist on disk, so a module's source could + not be found and no breakpoint in it would bind. The prefix is now mapped back + to the real directories derived from the executable's location. ### Added diff --git a/src/debugger/core/controller.ml b/src/debugger/core/controller.ml index b54543a..0beeee1 100644 --- a/src/debugger/core/controller.ml +++ b/src/debugger/core/controller.ml @@ -54,7 +54,8 @@ let root ?debug_filter debug_sock symbols_file = assert (neg1 = -1); let%lwt pid = Lwt_io.BE.read_int conn.io.in_ in let frag = Code_fragment.make Debug_types.main_frag debug_info in - let symbols = Symbols.create ?debug_filter () in + let workspace_dirs = Symbols.derive_workspace_dirs symbols_file in + let symbols = Symbols.create ?debug_filter ~workspace_dirs () in Symbols.add_fragment symbols frag;%lwt let%lwt debug_modules = _set_frag_events symbols conn frag in Lwt.return diff --git a/src/debugger/core/symbols/symbols.ml b/src/debugger/core/symbols/symbols.ml index 836eef8..f542407 100644 --- a/src/debugger/core/symbols/symbols.ml +++ b/src/debugger/core/symbols/symbols.ml @@ -3,6 +3,7 @@ open Ground type t = { get_source_dir : string -> string option; debug_filter : string -> bool; + workspace_dirs : string list; mutable frags : Code_fragment.t Map.Make(Int).t; mutable source_module_by_digest : Code_module.t Map.Make(Digest).t; mutable version : int; @@ -12,17 +13,73 @@ type t = { module IntMap_ = Map.Make (Int) module DigestMap_ = Map.Make (Digest) -let create ?(get_source_dir = fun _ -> None) ?(debug_filter = fun _ -> true) () - = +let create ?(get_source_dir = fun _ -> None) ?(debug_filter = fun _ -> true) + ?(workspace_dirs = []) () = { get_source_dir; debug_filter; + workspace_dirs; frags = IntMap_.empty; source_module_by_digest = DigestMap_.empty; version = 0; dummy = (); } +(* Since dune 3.0, [map_workspace_root] is on by default and rewrites the build + directory prefix in the debug info to a fixed "/workspace_root", which does + not exist on disk, so a module's source cannot be found there. Rewrite that + prefix back to the real directories derived from the executable's location + ([workspace_dirs]). A dir with no such prefix is left as is. *) +let workspace_root_prefix = "/workspace_root" + +let remap_dir workspace_dirs dir = + let n = String.length workspace_root_prefix in + let has_prefix = + String.length dir >= n + && String.sub dir 0 n = workspace_root_prefix + && (String.length dir = n || dir.[n] = '/') + in + if has_prefix && workspace_dirs <> [] then + let suffix = String.sub dir n (String.length dir - n) in + List.map (fun root -> root ^ suffix) workspace_dirs + else [ dir ] + +(* The real directories that dune's "/workspace_root" stands for, derived from + the executable's path. A dune executable lives at + /_build//<...>, and dune mirrors the source tree under the + build context, so both the source root and the build context + /_build/ hold the sources (byte-identical copies). The source + root is listed first so a resolved source is the user's own file rather than + the build copy. Returns [] when the path is not under a "_build" directory, + in which case no rewriting happens. *) +let derive_workspace_dirs executable = + let executable = + if Filename.is_relative executable then + Filename.concat (Sys.getcwd ()) executable + else executable + in + let marker = "/_build/" in + let marker_len = String.length marker in + let len = String.length executable in + let rec find i = + if i + marker_len > len then None + else if String.sub executable i marker_len = marker then Some i + else find (i + 1) + in + match find 0 with + | None -> [] + | Some i -> + let source_root = String.sub executable 0 i in + let after = + String.sub executable (i + marker_len) (len - i - marker_len) + in + let context = + match String.index_opt after '/' with + | Some j -> String.sub after 0 j + | None -> after + in + [ source_root; source_root ^ marker ^ context ] + let dup t = { t with dummy = () } let add_fragment t frag = @@ -32,6 +89,9 @@ let add_fragment t frag = | Some dir -> [ dir ] | None -> search_dirs in + let search_dirs = + search_dirs |> List.concat_map (remap_dir t.workspace_dirs) + in let module_id' = Str.split (Str.regexp "__") module_id |> List.rev |> List.hd in diff --git a/test/dune b/test/dune index 9dccf21..9ff5191 100644 --- a/test/dune +++ b/test/dune @@ -16,8 +16,10 @@ (libraries dap.types dap.rpc_lwt lwt lwt.unix lwt_react)) (executables - (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) + (names test_scopes test_frames test_stepping test_values test_heap test_indexed + test_dune_source) + (modules test_scopes test_frames test_stepping test_values test_heap test_indexed + test_dune_source) (preprocess (pps lwt_ppx)) (libraries dap.types dap_client lwt lwt.unix)) @@ -120,11 +122,27 @@ (action (diff test_indexed.expected test_indexed.actual))) +(rule + (targets test_dune_source.actual) + (deps + (:driver test_dune_source.exe) + (:adapter %{exe:../src/main/main.exe}) + fixtures/wsroot.bc + fixtures/wsroot.ml) + (action + (setenv EARLYBIRD_ADAPTER %{adapter} + (with-stdout-to %{targets} (run %{driver}))))) + +(rule + (alias runtest) + (action + (diff test_dune_source.expected test_dune_source.actual))) + ; --- symbol table, exercised directly -------------------------------------- -(executable - (name test_events) - (modules test_events) +(executables + (names test_events test_workspace) + (modules test_events test_workspace) (preprocess (pps lwt_ppx)) (libraries debugger lwt lwt.unix)) @@ -142,3 +160,15 @@ (alias runtest) (action (diff test_events.expected test_events.actual))) + +(rule + (targets test_workspace.actual) + (deps + (:driver test_workspace.exe)) + (action + (with-stdout-to %{targets} (run %{driver})))) + +(rule + (alias runtest) + (action + (diff test_workspace.expected test_workspace.actual))) diff --git a/test/fixtures/dune b/test/fixtures/dune index 93af568..7dbae60 100644 --- a/test/fixtures/dune +++ b/test/fixtures/dune @@ -20,3 +20,13 @@ (deps closure.ml) (action (run %{bin:ocamlc} -g closure.ml -o closure.bc))) + +; wsroot.bc mimics a dune >= 3.0 build: its debug info records the source search +; dir as "/workspace_root/test/fixtures" rather than a real path. See +; make_wsroot_bc.sh and test_dune_source.ml. + +(rule + (targets wsroot.bc) + (deps wsroot.ml make_wsroot_bc.sh) + (action + (run sh make_wsroot_bc.sh %{bin:ocamlc} %{targets} wsroot.ml))) diff --git a/test/fixtures/make_wsroot_bc.sh b/test/fixtures/make_wsroot_bc.sh new file mode 100644 index 0000000..3003a88 --- /dev/null +++ b/test/fixtures/make_wsroot_bc.sh @@ -0,0 +1,33 @@ +#!/bin/sh +# Build a bytecode executable whose debug info uses dune's "/workspace_root" +# search-dir prefix, the way a dune >= 3.0 build does (map_workspace_root is on +# by default), but without needing a real dune build. This lets the integration +# test check that the adapter can still resolve such sources and bind +# breakpoints in them. See test/test_dune_source.ml. +# +# dune achieves the rewrite with BUILD_PATH_PREFIX_MAP, which the compiler reads; +# we do the same here. The mapped directory is created under the current +# directory and the source is compiled from inside it so that the recorded +# search dir is exactly "/workspace_root/test/fixtures". Physical paths (pwd -P) +# are used so the prefix matches what the compiler records even when the build +# runs under a symlinked directory (e.g. /tmp -> /private/tmp on macOS). +set -e + +ocamlc=$1 +out=$2 +src=$3 + +orig=$(pwd -P) +case $out in +/*) ;; +*) out=$orig/$out ;; +esac + +root=$orig/_wsroot +rm -rf "$root" +mkdir -p "$root/test/fixtures" +cp "$src" "$root/test/fixtures/wsroot.ml" + +cd "$root/test/fixtures" +BUILD_PATH_PREFIX_MAP="/workspace_root=$root" \ + "$ocamlc" -g -I "$(pwd -P)" wsroot.ml -o "$out" diff --git a/test/fixtures/wsroot.ml b/test/fixtures/wsroot.ml new file mode 100644 index 0000000..7840599 --- /dev/null +++ b/test/fixtures/wsroot.ml @@ -0,0 +1,4 @@ +let add x y = + let s = x + y in + s +let () = Printf.printf "%d\n" (add 2 3) diff --git a/test/test_dune_source.expected b/test/test_dune_source.expected new file mode 100644 index 0000000..64969ee --- /dev/null +++ b/test/test_dune_source.expected @@ -0,0 +1,4 @@ +stopped at Wsroot.add:3 + y = 3 + x = 2 + s = 5 diff --git a/test/test_dune_source.ml b/test/test_dune_source.ml new file mode 100644 index 0000000..49327c5 --- /dev/null +++ b/test/test_dune_source.ml @@ -0,0 +1,26 @@ +(* A breakpoint set in a source whose debug info uses dune's "/workspace_root" + prefix should still bind. Since dune 3.0, map_workspace_root is on by default + and rewrites the build directory in the debug info to a fixed + "/workspace_root" that does not exist on disk; the adapter must map it back to + the real directory (derived from the executable's location) to find the + source. Without that, the source is never resolved, so no breakpoint in the + module can bind and the program runs to completion. See the wsroot.bc rule in + fixtures/dune. *) + +open Debug_protocol + +let main () = + (* Line 3 is [let s = x + y in], inside Wsroot.add. *) + Dap_client.with_session ~program:"fixtures/wsroot.bc" + ~source:"fixtures/wsroot.ml" ~breakpoints:[ 3 ] (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 at %s:%d\n" frame.name frame.line; + let%lwt locals = Dap_client.scope t ~frame ~name:"Stack" in + locals + |> List.iter (fun (variable : Variable.t) -> + Printf.printf " %s = %s\n" variable.name variable.value); + Lwt.return ()) + +let () = Lwt_main.run (main ()) diff --git a/test/test_workspace.expected b/test/test_workspace.expected new file mode 100644 index 0000000..28853a3 --- /dev/null +++ b/test/test_workspace.expected @@ -0,0 +1,22 @@ +== derive_workspace_dirs + /home/me/proj/_build/default/bin/main.bc + -> [/home/me/proj; /home/me/proj/_build/default] + /home/me/proj/_build/default/lib/sub/sub.bc + -> [/home/me/proj; /home/me/proj/_build/default] + /home/me/proj/_build/foo/bin/main.bc + -> [/home/me/proj; /home/me/proj/_build/foo] + /home/me/proj/bin/main.bc + -> [] +== remap_dir + /workspace_root + -> [/home/me/proj; /home/me/proj/_build/default] + /workspace_root/bin + -> [/home/me/proj/bin; /home/me/proj/_build/default/bin] + /workspace_root/lib/sub/.sub.objs/byte + -> [/home/me/proj/lib/sub/.sub.objs/byte; /home/me/proj/_build/default/lib/sub/.sub.objs/byte] + /home/me/.opam/lib/ocaml + -> [/home/me/.opam/lib/ocaml] + /workspace_root_other/bin + -> [/workspace_root_other/bin] + (no workspace dirs) /workspace_root/bin + -> [/workspace_root/bin] diff --git a/test/test_workspace.ml b/test/test_workspace.ml new file mode 100644 index 0000000..80bf6c5 --- /dev/null +++ b/test/test_workspace.ml @@ -0,0 +1,45 @@ +(* Unit tests for the "/workspace_root" path handling that backs the dune source + resolution fix (see Symbols.derive_workspace_dirs / Symbols.remap_dir). + + derive_workspace_dirs turns an executable path into the real directories that + dune's "/workspace_root" stands for; remap_dir rewrites a recorded search dir + using them. Both are pure, so they are checked directly here. *) + +open Debugger + +let show_list l = "[" ^ String.concat "; " l ^ "]" + +let () = + print_endline "== derive_workspace_dirs"; + [ + "/home/me/proj/_build/default/bin/main.bc"; + "/home/me/proj/_build/default/lib/sub/sub.bc"; + "/home/me/proj/_build/foo/bin/main.bc"; + (* not under a _build directory: nothing to derive *) + "/home/me/proj/bin/main.bc"; + ] + |> List.iter (fun path -> + Printf.printf " %s\n -> %s\n" path + (show_list (Symbols.derive_workspace_dirs path))); + + print_endline "== remap_dir"; + let workspace_dirs = + [ "/home/me/proj"; "/home/me/proj/_build/default" ] + in + [ + (* rewritten against each workspace dir *) + "/workspace_root"; + "/workspace_root/bin"; + "/workspace_root/lib/sub/.sub.objs/byte"; + (* a real path is left untouched ... *) + "/home/me/.opam/lib/ocaml"; + (* ... and "/workspace_root" is only a prefix on a path boundary *) + "/workspace_root_other/bin"; + ] + |> List.iter (fun dir -> + Printf.printf " %s\n -> %s\n" dir + (show_list (Symbols.remap_dir workspace_dirs dir))); + + (* With no workspace dirs (executable not under _build), nothing is rewritten. *) + Printf.printf " (no workspace dirs) /workspace_root/bin\n -> %s\n" + (show_list (Symbols.remap_dir [] "/workspace_root/bin"))