Merge pull request #21 from talex5/cancel

Show cancellations

Author: talex5

lib/layout.ml

@@ -46,6 +46,7 @@ end
 
 type event =
   | Log of string
+  | Error of string
   | Create_cc of string * item
   | Add_fiber of { parent : int; child : item }
 and item = {
@@ -87,6 +88,7 @@ let get t id = Ids.find_opt id t.items
 
 let map_event f : Trace.event -> event = function
   | Log x -> Log x
+  | Error x -> Error x
   | Create_cc (ty, x) -> Create_cc (ty, f x)
   | Add_fiber { parent; child } -> Add_fiber { parent; child = f child }
 
@@ -112,7 +114,7 @@ let layout ~duration (ring : Ring.t) =
     let intervals = ref [] in
     i.events |> Array.iter (fun (ts, e) ->
         match e with
-        | Log _ ->
+        | Log _ | Error _ ->
           if i.end_cc_label = None then (
               i.end_cc_label <- Some ts;
             )
@@ -131,7 +133,7 @@ let layout ~duration (ring : Ring.t) =
     let start_fibers = List.length !intervals in
     i.events |> Array.iter (fun (ts, e) ->
         match e with
-        | Log _ | Create_cc _ -> ()
+        | Log _ | Error _ | Create_cc _ -> ()
         | Add_fiber { parent; child } ->
           if debug_layout then Fmt.epr "%d gets fiber %d, created by %d@." i.id child.id parent;
           let stop = Option.value child.end_time ~default:duration in
@@ -161,7 +163,7 @@ let layout ~duration (ring : Ring.t) =
     i.end_cc_label <- None;
     i.events |> Array.iter (fun (_ts, e) ->
         match e with
-        | Log _ | Create_cc _ -> ()
+        | Log _ | Error _ | Create_cc _ -> ()
         | Add_fiber { parent = _; child } ->
           visit ~y:(ring.y + i.height) child;
           i.height <- child.y - ring.y + child.height;

lib/render.ml

@@ -119,19 +119,26 @@ module Make (C : CANVAS) = struct
         let x = View.x_of_time v ts in
         link_fibers v cr ~x parent child
       | Create_cc (ty, cc) -> render_cc v cr ts cc ty
-      | Log msg ->
+      | Log msg | Error msg ->
+        let is_error = match e with Error _ -> true | _ -> false in
         let x = View.x_of_time v ts in
-        let y = y_of_row v item.y +. 10. in
-        C.move_to cr ~x ~y:(y +. 3.);
-        C.line_to cr ~x ~y:(y -. 3.);
-        C.set_source_rgb cr ~r:0.0 ~g:0.0 ~b:0.0;
+        let y = y_of_row v item.y in
+        if is_error then (
+          C.set_source_rgb cr ~r:0.8 ~g:0.0 ~b:0.0;
+          C.move_to cr ~x ~y;
+          C.line_to cr ~x ~y:(y +. float item.height *. View.pixels_per_row);
+        ) else (
+          C.set_source_rgb cr ~r:0.0 ~g:0.0 ~b:0.0;
+          C.move_to cr ~x ~y:(y +. 13.);
+          C.line_to cr ~x ~y:(y +. 7.);
+        );
         C.stroke cr;
         C.set_font_size cr Style.small_text;
         let clip_area = next |> Option.map (fun t2 ->
             let x2 = View.x_of_time v t2 in
             (x2 -. x -. 2.0, v.height)
           ) in
-        C.paint_text cr ~x:(x +. 2.) ~y:(y -. 2.) msg
+        C.paint_text cr ~x:(x +. 2.) ~y:(y +. 8.) msg
           ?clip_area
     done
 

lib/trace.ml

@@ -17,6 +17,7 @@ type activation = [
 
 type event =
   | Log of string
+  | Error of string
   | Create_cc of string * item
   | Add_fiber of { parent : int; child : item }
 and item = {
@@ -185,6 +186,11 @@ let process_event t e =
     fiber_of_thread t thread |> Option.iter @@ fun fiber ->
     let item = get t (fiber.inner_cc) in
     item.events <- (timestamp, Log msg) :: item.events
+  | "eio", "error", Instant ->
+    let id = List.assoc_opt "id" args |> Option.get |> id_of_pointer in
+    let msg = List.assoc_opt "message" args |> Option.get |> as_string in
+    let item = get t id in
+    item.events <- (timestamp, Error msg) :: item.events
   | "eio", "exit-fiber", Instant ->
     let id = List.assoc_opt "id" args |> Option.get |> id_of_pointer in
     let item = get t id in

src/record.ml

@@ -148,6 +148,11 @@ let callbacks t =
          Write.instant_event t.fxt ~thread ~ts ~name:"domain-spawn" ~category:"eio" ~args:[
            "parent", `Pointer (Int64.of_int parent);
          ];
+       | `Error (id, err) ->
+         Write.instant_event t.fxt ~thread ~ts ~name:"error" ~category:"eio" ~args:[
+           "id", `Pointer (Int64.of_int id);
+           "message", `String err;
+         ]
        | _ -> ()
     )