Resolve dune >= 3.0 sources by mapping /workspace_root

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
 

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

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

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
+   <root>/_build/<context>/<...>, and dune mirrors the source tree under the
+   build context, so both the source root <root> and the build context
+   <root>/_build/<context> 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

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 = {

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"