Fix crash inspecting indexed values with an unfiltered variables request

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
 

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/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"

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,97 @@
   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 --------------------------------------
+
+(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)))

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))

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)))

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"