New feature: tracking if and match branches

Not implemented yet: `%debug_notrace`

CHANGELOG.md

@@ -3,8 +3,10 @@
 ### Added
 
 - A new optional PrintBox-only setting `highlight_terms`, which applies a frame / border on paths to leaves matching a regular expression.
-- A corresponding setting `exclude_on_path` -- if this regular expression matches on a log, its children have no effect on its highlight status. I.e., `exclude_on_path` stops the continued propagation of highlights.
-- A flag `highlighted_roots` prevents outputting toplevel boxes that have not been highlighted.
+  - A corresponding setting `exclude_on_path` -- if this regular expression matches on a log, its children have no effect on its highlight status. I.e., `exclude_on_path` stops the continued propagation of highlights.
+  - A flag `highlighted_roots` prevents outputting toplevel boxes that have not been highlighted.
+- A set of extension points `%track_sexp`, `%track_pp` etc. that parallel `%debug_sexp`, `%debug_pp` etc. but additionally log which `if` and `match` branch got executed.
+  - An extension point `%debug_notrace` that turns off logging the branch of the specific `if` or `match` expression. It is ignored by the `%debug_` extension points.
 
 ## [0.6.2] -- 2023-12-21
 

ppx_minidebug.ml

@@ -98,6 +98,7 @@ let log_value_show ~loc ~typ ~descr_loc exp =
       ~v:([%show: [%t typ]] [%e exp])]
 
 let log_value = ref log_value_sexp
+let track_branches = ref false
 
 let log_string ~loc ~descr_loc s =
   [%expr
@@ -241,7 +242,7 @@ let traverse =
     method! expression e =
       let callback e = self#expression e in
       match e with
-      | { pexp_desc = Pexp_let (rec_flag, bindings, body); pexp_loc = _; _ } ->
+      | { pexp_desc = Pexp_let (rec_flag, bindings, body); _ } ->
           let bindings =
             List.map
               (fun vb ->
@@ -250,8 +251,61 @@ let traverse =
                   { vb with pvb_expr = super#expression vb.pvb_expr })
               bindings
           in
-          let body = callback body in
-          { e with pexp_desc = Pexp_let (rec_flag, bindings, body) }
+          { e with pexp_desc = Pexp_let (rec_flag, bindings, callback body) }
+      | { pexp_desc = Pexp_match (expr, cases); _ } when !track_branches ->
+          let cases =
+            List.mapi
+              (fun i { pc_lhs; pc_guard; pc_rhs } ->
+                let pc_guard = Option.map callback pc_guard in
+                let loc = pc_rhs.pexp_loc in
+                let i = string_of_int i in
+                let pc_rhs =
+                  [%expr
+                    [%e
+                      open_log_preamble ~brief:true
+                        ~message:(" <match -- branch " ^ i ^ ">")
+                        ~loc:pc_lhs.ppat_loc ()];
+                    match [%e callback pc_rhs] with
+                    | match__result ->
+                        Debug_runtime.close_log ();
+                        match__result
+                    | exception e ->
+                        Debug_runtime.close_log ();
+                        raise e]
+                in
+                { pc_lhs; pc_guard; pc_rhs })
+              cases
+          in
+          { e with pexp_desc = Pexp_match (callback expr, cases) }
+      | { pexp_desc = Pexp_ifthenelse (if_, then_, else_); _ } when !track_branches ->
+          let then_ =
+            let loc = then_.pexp_loc in
+            [%expr
+              [%e open_log_preamble ~brief:true ~message:" <if -- then branch>" ~loc ()];
+              match [%e callback then_] with
+              | if_then__result ->
+                  Debug_runtime.close_log ();
+                  if_then__result
+              | exception e ->
+                  Debug_runtime.close_log ();
+                  raise e]
+          in
+          let else_ =
+            Option.map
+              (fun else_ ->
+                let loc = else_.pexp_loc in
+                [%expr
+                  [%e open_log_preamble ~brief:true ~message:" <if -- else branch>" ~loc ()];
+                  match [%e callback else_] with
+                  | if_else__result ->
+                      Debug_runtime.close_log ();
+                      if_else__result
+                  | exception e ->
+                      Debug_runtime.close_log ();
+                      raise e])
+              else_
+          in
+          { e with pexp_desc = Pexp_ifthenelse (callback if_, then_, else_) }
       | _ -> super#expression e
 
     method! structure_item si =
@@ -292,80 +346,125 @@ let str_expander ~loc payload =
           pincl_attributes = [];
         }
 
-let debug_this_expander_sexp ~ctxt:_ payload =
+let debug_this_expander_sexp ~tracking ~ctxt:_ payload =
   log_value := log_value_sexp;
+  track_branches := tracking;
   debug_this_expander payload
 
-let debug_expander_sexp ~ctxt:_ payload =
+let debug_expander_sexp ~tracking ~ctxt:_ payload =
   log_value := log_value_sexp;
+  track_branches := tracking;
   debug_expander payload
 
-let str_expander_sexp ~loc ~path:_ payload =
+let str_expander_sexp ~tracking ~loc ~path:_ payload =
   log_value := log_value_sexp;
+  track_branches := tracking;
   str_expander ~loc payload
 
-let debug_this_expander_pp ~ctxt:_ payload =
+let debug_this_expander_pp ~tracking ~ctxt:_ payload =
   log_value := log_value_pp;
+  track_branches := tracking;
   debug_this_expander payload
 
-let debug_expander_pp ~ctxt:_ payload =
+let debug_expander_pp ~tracking ~ctxt:_ payload =
   log_value := log_value_pp;
+  track_branches := tracking;
   debug_expander payload
 
-let str_expander_pp ~loc ~path:_ payload =
+let str_expander_pp ~tracking ~loc ~path:_ payload =
   log_value := log_value_pp;
+  track_branches := tracking;
   str_expander ~loc payload
 
-let debug_this_expander_show ~ctxt:_ payload =
+let debug_this_expander_show ~tracking ~ctxt:_ payload =
   log_value := log_value_show;
+  track_branches := tracking;
   debug_this_expander payload
 
-let debug_expander_show ~ctxt:_ payload =
+let debug_expander_show ~tracking ~ctxt:_ payload =
   log_value := log_value_show;
+  track_branches := tracking;
   debug_expander payload
 
-let str_expander_show ~loc ~path:_ payload =
+let str_expander_show ~tracking ~loc ~path:_ payload =
   log_value := log_value_show;
+  track_branches := tracking;
   str_expander ~loc payload
 
 let rules =
   [
     Ppxlib.Context_free.Rule.extension
     @@ Extension.V3.declare "debug_sexp" Extension.Context.expression
          Ast_pattern.(single_expr_payload __)
-         debug_expander_sexp;
+         (debug_expander_sexp ~tracking:false);
     Ppxlib.Context_free.Rule.extension
     @@ Extension.V3.declare "debug_this_sexp" Extension.Context.expression
          Ast_pattern.(single_expr_payload __)
-         debug_this_expander_sexp;
+         (debug_this_expander_sexp ~tracking:false);
     Ppxlib.Context_free.Rule.extension
     @@ Extension.declare "debug_sexp" Extension.Context.structure_item
          Ast_pattern.(pstr __)
-         str_expander_sexp;
+         (str_expander_sexp ~tracking:false);
     Ppxlib.Context_free.Rule.extension
     @@ Extension.V3.declare "debug_pp" Extension.Context.expression
          Ast_pattern.(single_expr_payload __)
-         debug_expander_pp;
+         (debug_expander_pp ~tracking:false);
     Ppxlib.Context_free.Rule.extension
     @@ Extension.V3.declare "debug_this_pp" Extension.Context.expression
          Ast_pattern.(single_expr_payload __)
-         debug_this_expander_pp;
+         (debug_this_expander_pp ~tracking:false);
     Ppxlib.Context_free.Rule.extension
     @@ Extension.declare "debug_pp" Extension.Context.structure_item
          Ast_pattern.(pstr __)
-         str_expander_pp;
+         (str_expander_pp ~tracking:false);
     Ppxlib.Context_free.Rule.extension
     @@ Extension.V3.declare "debug_show" Extension.Context.expression
          Ast_pattern.(single_expr_payload __)
-         debug_expander_show;
+         (debug_expander_show ~tracking:false);
     Ppxlib.Context_free.Rule.extension
     @@ Extension.V3.declare "debug_this_show" Extension.Context.expression
          Ast_pattern.(single_expr_payload __)
-         debug_this_expander_show;
+         (debug_this_expander_show ~tracking:false);
     Ppxlib.Context_free.Rule.extension
     @@ Extension.declare "debug_show" Extension.Context.structure_item
          Ast_pattern.(pstr __)
-         str_expander_show;
+         (str_expander_show ~tracking:false);
+    Ppxlib.Context_free.Rule.extension
+    @@ Extension.V3.declare "track_sexp" Extension.Context.expression
+         Ast_pattern.(single_expr_payload __)
+         (debug_expander_sexp ~tracking:true);
+    Ppxlib.Context_free.Rule.extension
+    @@ Extension.V3.declare "track_this_sexp" Extension.Context.expression
+         Ast_pattern.(single_expr_payload __)
+         (debug_this_expander_sexp ~tracking:true);
+    Ppxlib.Context_free.Rule.extension
+    @@ Extension.declare "track_sexp" Extension.Context.structure_item
+         Ast_pattern.(pstr __)
+         (str_expander_sexp ~tracking:true);
+    Ppxlib.Context_free.Rule.extension
+    @@ Extension.V3.declare "track_pp" Extension.Context.expression
+         Ast_pattern.(single_expr_payload __)
+         (debug_expander_pp ~tracking:true);
+    Ppxlib.Context_free.Rule.extension
+    @@ Extension.V3.declare "track_this_pp" Extension.Context.expression
+         Ast_pattern.(single_expr_payload __)
+         (debug_this_expander_pp ~tracking:true);
+    Ppxlib.Context_free.Rule.extension
+    @@ Extension.declare "track_pp" Extension.Context.structure_item
+         Ast_pattern.(pstr __)
+         (str_expander_pp ~tracking:true);
+    Ppxlib.Context_free.Rule.extension
+    @@ Extension.V3.declare "track_show" Extension.Context.expression
+         Ast_pattern.(single_expr_payload __)
+         (debug_expander_show ~tracking:true);
+    Ppxlib.Context_free.Rule.extension
+    @@ Extension.V3.declare "track_this_show" Extension.Context.expression
+         Ast_pattern.(single_expr_payload __)
+         (debug_this_expander_show ~tracking:true);
+    Ppxlib.Context_free.Rule.extension
+    @@ Extension.declare "track_show" Extension.Context.structure_item
+         Ast_pattern.(pstr __)
+         (str_expander_show ~tracking:true);
   ]
 
 let () = Driver.register_transformation ~rules "ppx_minidebug"

test/test_expect_test.ml

@@ -312,7 +312,9 @@ let%expect_test "%debug_show PrintBox to stdout num children exceeded nested" =
       Raised exception: ppx_minidebug: max_num_children exceeded |}]
 
 let%expect_test "%debug_show PrintBox to stdout highlight" =
-  let module Debug_runtime = (val Minidebug_runtime.debug ~highlight_terms:(Re.str "3") ()) in
+  let module Debug_runtime =
+    (val Minidebug_runtime.debug ~highlight_terms:(Re.str "3") ())
+  in
   let%debug_this_show rec loop_highlight (x : int) : int =
     let z : int = (x - 1) / 2 in
     if x <= 0 then 0 else z + loop_highlight (z + (x / 2))
@@ -322,52 +324,52 @@ let%expect_test "%debug_show PrintBox to stdout highlight" =
     {|
       BEGIN DEBUG SESSION
       ┌────────────────────────────────────────────────────────┐
-      │"test/test_expect_test.ml":316:41-318:58: loop_highlight│
+      │"test/test_expect_test.ml":318:41-320:58: loop_highlight│
       ├────────────────────────────────────────────────────────┘
       ├─x = 7
       ├─┬──────────────────────────────────┐
-      │ │"test/test_expect_test.ml":317:8: │
+      │ │"test/test_expect_test.ml":319:8: │
       │ ├──────────────────────────────────┘
       │ └─┬─────┐
       │   │z = 3│
       │   └─────┘
       ├─┬────────────────────────────────────────────────────────┐
-      │ │"test/test_expect_test.ml":316:41-318:58: loop_highlight│
+      │ │"test/test_expect_test.ml":318:41-320:58: loop_highlight│
       │ ├────────────────────────────────────────────────────────┘
       │ ├─x = 6
-      │ ├─"test/test_expect_test.ml":317:8:
+      │ ├─"test/test_expect_test.ml":319:8:
       │ │ └─z = 2
       │ ├─┬────────────────────────────────────────────────────────┐
-      │ │ │"test/test_expect_test.ml":316:41-318:58: loop_highlight│
+      │ │ │"test/test_expect_test.ml":318:41-320:58: loop_highlight│
       │ │ ├────────────────────────────────────────────────────────┘
       │ │ ├─x = 5
-      │ │ ├─"test/test_expect_test.ml":317:8:
+      │ │ ├─"test/test_expect_test.ml":319:8:
       │ │ │ └─z = 2
       │ │ ├─┬────────────────────────────────────────────────────────┐
-      │ │ │ │"test/test_expect_test.ml":316:41-318:58: loop_highlight│
+      │ │ │ │"test/test_expect_test.ml":318:41-320:58: loop_highlight│
       │ │ │ ├────────────────────────────────────────────────────────┘
       │ │ │ ├─x = 4
-      │ │ │ ├─"test/test_expect_test.ml":317:8:
+      │ │ │ ├─"test/test_expect_test.ml":319:8:
       │ │ │ │ └─z = 1
       │ │ │ ├─┬────────────────────────────────────────────────────────┐
-      │ │ │ │ │"test/test_expect_test.ml":316:41-318:58: loop_highlight│
+      │ │ │ │ │"test/test_expect_test.ml":318:41-320:58: loop_highlight│
       │ │ │ │ ├────────────────────────────────────────────────────────┘
       │ │ │ │ ├─┬─────┐
       │ │ │ │ │ │x = 3│
       │ │ │ │ │ └─────┘
-      │ │ │ │ ├─"test/test_expect_test.ml":317:8:
+      │ │ │ │ ├─"test/test_expect_test.ml":319:8:
       │ │ │ │ │ └─z = 1
-      │ │ │ │ ├─"test/test_expect_test.ml":316:41-318:58: loop_highlight
+      │ │ │ │ ├─"test/test_expect_test.ml":318:41-320:58: loop_highlight
       │ │ │ │ │ ├─x = 2
-      │ │ │ │ │ ├─"test/test_expect_test.ml":317:8:
+      │ │ │ │ │ ├─"test/test_expect_test.ml":319:8:
       │ │ │ │ │ │ └─z = 0
-      │ │ │ │ │ ├─"test/test_expect_test.ml":316:41-318:58: loop_highlight
+      │ │ │ │ │ ├─"test/test_expect_test.ml":318:41-320:58: loop_highlight
       │ │ │ │ │ │ ├─x = 1
-      │ │ │ │ │ │ ├─"test/test_expect_test.ml":317:8:
+      │ │ │ │ │ │ ├─"test/test_expect_test.ml":319:8:
       │ │ │ │ │ │ │ └─z = 0
-      │ │ │ │ │ │ ├─"test/test_expect_test.ml":316:41-318:58: loop_highlight
+      │ │ │ │ │ │ ├─"test/test_expect_test.ml":318:41-320:58: loop_highlight
       │ │ │ │ │ │ │ ├─x = 0
-      │ │ │ │ │ │ │ ├─"test/test_expect_test.ml":317:8:
+      │ │ │ │ │ │ │ ├─"test/test_expect_test.ml":319:8:
       │ │ │ │ │ │ │ │ └─z = 0
       │ │ │ │ │ │ │ └─loop_highlight = 0
       │ │ │ │ │ │ └─loop_highlight = 0
@@ -378,3 +380,32 @@ let%expect_test "%debug_show PrintBox to stdout highlight" =
       │ └─loop_highlight = 6
       └─loop_highlight = 9
       9 |}]
+
+let%expect_test "%debug_show PrintBox to stdout with exception" =
+  let module Debug_runtime = (val Minidebug_runtime.debug ()) in
+  let%track_this_show track_branches (x : int) : int =
+    if x < 6 then match x with 0 -> 1 | 1 -> 0 | _ -> ~-x
+    else match x with 6 -> 5 | 7 -> 4 | _ -> x
+  in
+  let () =
+    try
+      print_endline @@ Int.to_string @@ track_branches 7;
+      print_endline @@ Int.to_string @@ track_branches 3
+    with _ -> print_endline "Raised exception."
+  in
+  [%expect
+    {|
+    BEGIN DEBUG SESSION
+    "test/test_expect_test.ml":386:37-388:46: track_branches
+    ├─x = 7
+    ├─"test/test_expect_test.ml":388:9: <if -- else branch>
+    │ └─"test/test_expect_test.ml":388:31: <match -- branch 1>
+    └─track_branches = 4
+    4
+    "test/test_expect_test.ml":386:37-388:46: track_branches
+    ├─x = 3
+    ├─"test/test_expect_test.ml":387:18: <if -- then branch>
+    │ └─"test/test_expect_test.ml":387:49: <match -- branch 2>
+    └─track_branches = -3
+    -3
+        |}]