Merge pull request #53 from hackwaly/feat/inspect-opaque

Add opaque value inspection

src/debugger/inspect/inspect.ml

@@ -1,4 +1,7 @@
 open Debug_types
+open Value_basic
+open Value_simple
+open Value_func
 
 type raw_value = Scene.obj * Types.type_expr
 
@@ -11,7 +14,53 @@ type t =
   ; get_indexed : int -> t Lwt.t
   ; list_named : (string * t) list Lwt.t >
 
+class opaque_block_value ~scene ~rv ~size =
+  object
+    inherit value
+    method! num_indexed = size
+
+    method! get_indexed (idx : int) : value Lwt.t =
+      let%lwt fldval = Scene.get_field scene rv idx in
+      dyn_adopt scene fldval
+
+    method to_short_string = "«opaque block»"
+  end
+
 let () =
+  (Value_basic.dyn_adopter :=
+     fun scene obj ->
+       let%lwt tag = Scene.get_tag scene obj in
+       if tag = Obj.string_tag then
+         let%lwt obj = Scene.marshal_obj scene obj in
+         Lwt.return (new string_value (Obj.magic obj))
+       else if tag = Obj.int_tag then
+         let%lwt obj = Scene.marshal_obj scene obj in
+         Lwt.return (new int_value (Obj.magic obj))
+       else if tag = Obj.double_tag then
+         let%lwt obj = Scene.marshal_obj scene obj in
+         Lwt.return (new float_value (Obj.magic obj))
+       else if tag = Obj.closure_tag then
+         let%lwt pc, loc =
+           if Scene.is_block obj then
+             let%lwt pc, loc = Scene.get_closure_code scene obj in
+             Lwt.return (Some pc, loc)
+           else Lwt.return (None, None)
+         in
+         Lwt.return (new func_value ?pc ?loc ())
+       else if tag = Obj.double_array_tag then
+         (* TODO: *)
+         Lwt.return unknown_value
+       else if tag = Obj.lazy_tag then (* TODO: *)
+         Lwt.return unknown_value
+       else if tag = Obj.abstract_tag then
+         Lwt.return unknown_value (* TODO: distinct abstract_value output? *)
+       else if tag = Obj.custom_tag then
+         Lwt.return unknown_value (* TODO: distinct custom_value output? can maybe extract identifier from custom_operations? *)
+       else if Scene.is_block obj then
+         let%lwt size = Scene.get_size scene obj in
+         Lwt.return (new opaque_block_value ~scene ~rv:obj ~size)
+       else Lwt.return unknown_value);
+
   Value_basic.adopters :=
     [
       Value_simple.adopter;
@@ -26,6 +75,8 @@ let () =
 
 let scope scene frame kind =
   match kind with
-  | `Stack -> (new Value_scope.local_scope_value ~scene ~frame ~kind:`Stack () :> t)
-  | `Heap -> (new Value_scope.local_scope_value ~scene ~frame ~kind:`Heap () :> t)
+  | `Stack ->
+      (new Value_scope.local_scope_value ~scene ~frame ~kind:`Stack () :> t)
+  | `Heap ->
+      (new Value_scope.local_scope_value ~scene ~frame ~kind:`Heap () :> t)
   | `Global -> (new Value_scope.global_scope_value ~scene ~frame () :> t)

src/debugger/inspect/scene.ml

@@ -6,7 +6,6 @@ open Instruct
 open Debug_types
 
 type t = Controller.t * int64
-
 type obj = Local of Obj.t | Remote of Wire_protocol.remote_value
 
 let from_controller c = (c, c.time)
@@ -146,13 +145,15 @@ let get_field (c, time) rv index =
               Lwt.return (Local (Obj.repr v)))
 
 let get_tag (c, time) rv =
-  match rv with
-  | Local v -> Lwt.return (Obj.tag v)
-  | Remote rv ->
-      _lock_conn (c, time) (fun conn ->
-          let%lwt hdr = Wire_protocol.get_header conn rv in
-          let tag = hdr land 0xff in
-          Lwt.return tag)
+  if not (is_block rv) then Lwt.return Obj.int_tag
+  else
+    match rv with
+    | Local v -> Lwt.return (Obj.tag v)
+    | Remote rv ->
+        _lock_conn (c, time) (fun conn ->
+            let%lwt hdr = Wire_protocol.get_header conn rv in
+            let tag = hdr land 0xff in
+            Lwt.return tag)
 
 let get_size (c, time) rv =
   match rv with

src/debugger/inspect/value_basic.ml

@@ -61,6 +61,12 @@ let adopters =
         value option Lwt.t)
         list)
 
+let dyn_adopter: (Scene.t -> Scene.obj -> value Lwt.t) ref =
+  ref (fun _scene _obj -> Lwt.return unknown_value)
+
+let dyn_adopt scene obj =
+  (!dyn_adopter) scene obj
+
 let adopt scene typenv obj ty =
   let rec resolve_type ty =
     match Types.get_desc ty with
@@ -86,4 +92,4 @@ let adopt scene typenv obj ty =
   try%lwt
     !adopters |> List.to_seq
     |> Lwt_seq.find_map_s (fun adopter -> adopter scene typenv obj ty)
-  with Not_found -> Lwt.return unknown_value
+  with Not_found -> dyn_adopt scene obj