diff --git a/CHANGELOG.md b/CHANGELOG.md index 29b27a6..35d60f0 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,6 +5,19 @@ * 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. +* 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/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/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/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..9ff5191 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,16 @@ (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 + 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)) +; --- protocol-driven scenarios --------------------------------------------- + (rule (targets test_scopes.actual) (deps @@ -25,12 +34,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 +50,125 @@ 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))) + +(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 -------------------------------------- + +(executables + (names test_events test_workspace) + (modules test_events test_workspace) + (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_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/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..7dbae60 100644 --- a/test/fixtures/dune +++ b/test/fixtures/dune @@ -8,3 +8,25 @@ (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))) + +; 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/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/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_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_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 ()) 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"))