From 73062e0a4730703ae7503a1672dfa0d1111ab37c Mon Sep 17 00:00:00 2001 From: Lukasz Stafiniak Date: Fri, 29 Dec 2023 22:25:49 +0100 Subject: [PATCH] New feature: tracking `if` and `match` branches Not implemented yet: `%debug_notrace` --- CHANGELOG.md | 6 +- ppx_minidebug.ml | 141 +++++++++++++++++++++++++++++++++------ test/test_expect_test.ml | 65 +++++++++++++----- 3 files changed, 172 insertions(+), 40 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 37526b2..cc9d36a 100644 --- a/CHANGELOG.md +++ b/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 diff --git a/ppx_minidebug.ml b/ppx_minidebug.ml index 14a4d7a..a2f768c 100644 --- a/ppx_minidebug.ml +++ b/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:(" ") + ~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:" " ~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:" " ~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,40 +346,49 @@ 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 = @@ -333,39 +396,75 @@ 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" diff --git a/test/test_expect_test.ml b/test/test_expect_test.ml index 51e36f2..107f362 100644 --- a/test/test_expect_test.ml +++ b/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: + │ └─"test/test_expect_test.ml":388:31: + └─track_branches = 4 + 4 + "test/test_expect_test.ml":386:37-388:46: track_branches + ├─x = 3 + ├─"test/test_expect_test.ml":387:18: + │ └─"test/test_expect_test.ml":387:49: + └─track_branches = -3 + -3 + |}]