Skip to content

Commit

Permalink
Completes the handling of local runtimes, and passing runtimes
Browse files Browse the repository at this point in the history 
for non-let-binding-of-fun expressions.
This fixes a couple of issues but I'm offline atm so can't check their numbers.
  • Loading branch information
@lukstafi
lukstafi committed Aug 4, 2024
1 parent 8e997f4 commit bc45506
Show file tree
Hide file tree
Showing 2 changed files with 103 additions and 32 deletions.
72 changes: 52 additions & 20 deletions ppx_minidebug.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -617,13 +617,15 @@ let rec collect_fun_typs arg_typs typ =
| Ptyp_arrow (_, arg_typ, typ) -> collect_fun_typs (arg_typ :: arg_typs) typ
| _ -> (List.rev arg_typs, typ)

let pass_runtime toplevel_opt_arg exp =
let pass_runtime ?(always = false) toplevel_opt_arg exp =
let loc = exp.pexp_loc in
(* Only pass runtime to functions. *)
match (toplevel_opt_arg, exp) with
| Generic, { pexp_desc = Pexp_newtype _ | Pexp_fun _ | Pexp_function _; _ } ->
match (always, toplevel_opt_arg, exp) with
| true, Generic, _
| _, Generic, { pexp_desc = Pexp_newtype _ | Pexp_fun _ | Pexp_function _; _ } ->
[%expr fun (_debug_runtime : (module Minidebug_runtime.Debug_runtime)) -> [%e exp]]
| PrintBox, { pexp_desc = Pexp_newtype _ | Pexp_fun _ | Pexp_function _; _ } ->
| true, PrintBox, _
| _, PrintBox, { pexp_desc = Pexp_newtype _ | Pexp_fun _ | Pexp_function _; _ } ->
[%expr
fun (_debug_runtime : (module Minidebug_runtime.PrintBox_runtime)) -> [%e exp]]
| _ -> exp
Expand Down Expand Up @@ -736,8 +738,8 @@ let debug_fun context callback ?typ ?ret_descr ?ret_typ exp =
let exp = expand_fun (unpack_runtime context.toplevel_opt_arg body) args in
pass_runtime context.toplevel_opt_arg exp

let debug_case context callback ?ret_descr ?ret_typ ?arg_typ kind i
{ pc_lhs; pc_guard; pc_rhs } =
let debug_case ?(unpack_context = Nested) context callback ?ret_descr ?ret_typ ?arg_typ
kind i { pc_lhs; pc_guard; pc_rhs } =
let log_count_before = !global_log_count in
let pc_guard = Option.map (callback context) pc_guard in
let loc = pc_lhs.ppat_loc in
Expand All @@ -762,18 +764,24 @@ let debug_case context callback ?ret_descr ?ret_typ ?arg_typ kind i
~log_count_before ~arg_logs ret_typ pc_rhs
in
let pc_rhs =
if is_local_debug_runtime context.toplevel_opt_arg then
if is_local_debug_runtime unpack_context then unpack_runtime unpack_context pc_rhs
else if is_local_debug_runtime context.toplevel_opt_arg then
unpack_runtime context.toplevel_opt_arg pc_rhs
else pc_rhs
in
{ pc_lhs; pc_guard; pc_rhs }

let debug_function context callback ~loc ?ret_descr ?ret_typ ?arg_typ cases =
let debug_function ?unpack_context context callback ~loc ?ret_descr ?ret_typ ?arg_typ
cases =
let unpack_context =
match unpack_context with None -> context.toplevel_opt_arg | Some ctx -> ctx
in
let nested = { context with toplevel_opt_arg = Nested } in
let exp =
A.pexp_function ~loc
(List.mapi
(debug_case nested callback ?ret_descr ?ret_typ ?arg_typ "function")
(debug_case ~unpack_context nested callback ?ret_descr ?ret_typ ?arg_typ
"function")
cases)
in
match context.toplevel_opt_arg with
Expand Down Expand Up @@ -1063,20 +1071,21 @@ let traverse_expression =
object (self)
inherit [context] Ast_traverse.map_with_context as super

method! expression context exp =
method! expression context orig_exp =
let callback context e = self#expression context e in
let restrict_to_explicit =
match context.log_level with Nothing | Prefixed _ -> true | _ -> false
in
let track_cases ?ret_descr ?ret_typ ?arg_typ kind =
List.mapi (debug_case context callback ?ret_descr ?ret_typ ?arg_typ kind)
in
let exp, ret_typ =
match exp with
let orig_exp, ret_typ =
match orig_exp with
| [%expr ([%e? exp] : [%t? typ])] -> (exp, Some typ)
| _ -> (exp, None)
| _ -> (orig_exp, None)
in
let loc = exp.pexp_loc in
let loc = orig_exp.pexp_loc in
let exp = orig_exp in
let exp =
match exp.pexp_desc with
| Pexp_let (rec_flag, bindings, body)
Expand Down Expand Up @@ -1111,6 +1120,7 @@ let traverse_expression =
| "_sexp" -> Sexp
| _ -> context.log_value
in
(* NOTE: it's a current bug to ignore _this_ here, but _this_ will go away. *)
let toplevel_opt_arg =
if String.length txt > 9 && String.sub txt 5 4 = "_rt_" then Generic
else if String.length txt > 10 && String.sub txt 5 5 = "_rtb_" then PrintBox
Expand Down Expand Up @@ -1206,6 +1216,15 @@ let traverse_expression =
| _ -> (None, None)
in
debug_function context callback ~loc:exp.pexp_loc ?arg_typ ?ret_typ cases
| Pexp_function cases
when is_local_debug_runtime context.toplevel_opt_arg
&& context.log_level <> Nothing ->
let arg_typ, ret_typ =
match ret_typ with
| Some { ptyp_desc = Ptyp_arrow (_, arg, ret); _ } -> (Some arg, Some ret)
| _ -> (None, None)
in
debug_function context callback ~loc:exp.pexp_loc ?arg_typ ?ret_typ cases
| Pexp_ifthenelse (if_, then_, else_)
when context.track_branches && context.log_level <> Nothing ->
let then_ =
Expand Down Expand Up @@ -1323,21 +1342,34 @@ let traverse_expression =
else transformed
| _ -> super#expression { context with toplevel_opt_arg = Nested } exp
in
let exp =
match (exp.pexp_desc, context.toplevel_opt_arg) with
| Pexp_let (_, [_], _), _
let unpacked_runtime, exp =
match (orig_exp.pexp_desc, context.toplevel_opt_arg) with
| ( Pexp_let
( _,
[
{
pvb_expr =
{ pexp_desc = Pexp_function _ | Pexp_newtype _ | Pexp_fun _; _ };
_;
};
],
_ ),
_ )
| Pexp_function _, _
| Pexp_newtype _, _
| Pexp_fun _, _
| _, Nested
| _, Toplevel_no_arg ->
exp
| _ -> unpack_runtime context.toplevel_opt_arg exp
(false, exp)
| _ -> (true, unpack_runtime context.toplevel_opt_arg exp)
in
let exp =
match ret_typ with None -> exp | Some typ -> [%expr ([%e exp] : [%t typ])]
in
exp
match (unpacked_runtime, context.toplevel_opt_arg) with
| true, (PrintBox | Generic) ->
pass_runtime ~always:true context.toplevel_opt_arg exp
| _ -> exp

method! structure_item context si =
(* Do not use for an entry_point, because it ignores the toplevel_opt_arg field! *)
Expand Down
63 changes: 51 additions & 12 deletions test/test_expect_test.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2241,7 +2241,7 @@ let%expect_test "%track_show list values_first_mode" =
10 |}]

let%expect_test "%track_rtb_show list runtime passing" =
let%track_rtb_show foo l : int =
let%track_this_rtb_show foo l : int =
match (l : int list) with [] -> 7 | y :: _ -> y * 2
in
let () =
Expand All @@ -2250,7 +2250,7 @@ let%expect_test "%track_rtb_show list runtime passing" =
(Minidebug_runtime.debug ~global_prefix:"foo-1" ~values_first_mode:true ())
[ 7 ]
in
let%track_rtb_show baz : int list -> int = function
let%track_this_rtb_show baz : int list -> int = function
| [] -> 7
| [ y ] -> y * 2
| [ y; z ] -> y + z
Expand All @@ -2272,7 +2272,7 @@ let%expect_test "%track_rtb_show list runtime passing" =
{|
BEGIN DEBUG SESSION foo-1
foo = 14
├─"test/test_expect_test.ml":2244:25
├─"test/test_expect_test.ml":2244:30
└─foo-1 <match -- branch 1> :: (y, _)
├─"test/test_expect_test.ml":2245:50
└─y = 7
Expand All @@ -2294,10 +2294,10 @@ let%expect_test "%track_rtb_show list runtime passing" =
10 |}]

let%expect_test "%track_rt_show procedure runtime passing" =
let%track_rt_show bar () = (fun () -> ()) () in
let%track_this_rt_show bar () = (fun () -> ()) () in
let () = bar (Minidebug_runtime.debug_flushing ~global_prefix:"bar-1" ()) () in
let () = bar (Minidebug_runtime.debug_flushing ~global_prefix:"bar-2" ()) () in
let%track_rt_show foo () =
let%track_this_rt_show foo () =
let () = () in
()
in
Expand All @@ -2306,23 +2306,23 @@ let%expect_test "%track_rt_show procedure runtime passing" =
[%expect
{|
BEGIN DEBUG SESSION bar-1
bar-1 bar begin "test/test_expect_test.ml":2297:24:
bar-1 fun:test_expect_test:2297 begin "test/test_expect_test.ml":2297:29:
bar-1 bar begin "test/test_expect_test.ml":2297:29:
bar-1 fun:test_expect_test:2297 begin "test/test_expect_test.ml":2297:34:
bar-1 fun:test_expect_test:2297 end
bar-1 bar end

BEGIN DEBUG SESSION bar-2
bar-2 bar begin "test/test_expect_test.ml":2297:24:
bar-2 fun:test_expect_test:2297 begin "test/test_expect_test.ml":2297:29:
bar-2 bar begin "test/test_expect_test.ml":2297:29:
bar-2 fun:test_expect_test:2297 begin "test/test_expect_test.ml":2297:34:
bar-2 fun:test_expect_test:2297 end
bar-2 bar end

BEGIN DEBUG SESSION foo-1
foo-1 foo begin "test/test_expect_test.ml":2300:24:
foo-1 foo begin "test/test_expect_test.ml":2300:29:
foo-1 foo end

BEGIN DEBUG SESSION foo-2
foo-2 foo begin "test/test_expect_test.ml":2300:24:
foo-2 foo begin "test/test_expect_test.ml":2300:29:
foo-2 foo end |}]

let%expect_test "%track_rt_show nested procedure runtime passing" =
Expand Down Expand Up @@ -3797,23 +3797,53 @@ let%expect_test "%track_l_show procedure runtime passing" =
{|
BEGIN DEBUG SESSION foo-1
foo-1 foo begin "test/test_expect_test.ml":3783:28:
"inside foo"
foo-1 foo end

BEGIN DEBUG SESSION foo-1
foo-1 <function -- branch 0> () begin "test/test_expect_test.ml":3788:4:
"inside bar"
foo-1 <function -- branch 0> () end

BEGIN DEBUG SESSION foo-2
foo-2 foo begin "test/test_expect_test.ml":3783:28:
"inside foo"
foo-2 foo end

BEGIN DEBUG SESSION foo-2
foo-2 <function -- branch 0> () begin "test/test_expect_test.ml":3788:4:
"inside bar"
foo-2 <function -- branch 0> () end

BEGIN DEBUG SESSION foo-3
foo-3 foo begin "test/test_expect_test.ml":3783:28:
"inside foo"
foo-3 foo end

BEGIN DEBUG SESSION foo-3
foo-3 <function -- branch 0> () begin "test/test_expect_test.ml":3788:4:
"inside bar"
foo-3 <function -- branch 0> () end

BEGIN DEBUG SESSION foo-4
foo-4 foo begin "test/test_expect_test.ml":3783:28:
"inside foo"
foo-4 foo end

BEGIN DEBUG SESSION foo-4
foo-4 <function -- branch 0> () begin "test/test_expect_test.ml":3788:4:
"inside bar"
foo-4 <function -- branch 0> () end

BEGIN DEBUG SESSION foo-5
foo-5 foo begin "test/test_expect_test.ml":3783:28:
"inside foo"
foo-5 foo end

BEGIN DEBUG SESSION foo-5
foo-5 <function -- branch 0> () begin "test/test_expect_test.ml":3788:4:
"inside bar"
foo-5 <function -- branch 0> () end
|}]

let%expect_test "%track_rt_show expression runtime passing" =
Expand All @@ -3827,5 +3857,14 @@ let%expect_test "%track_rt_show expression runtime passing" =
"test B";
[%log "line B"]]]
(Minidebug_runtime.debug_flushing ~global_prefix:"t2" ());
[%expect {| |}]
[%expect {|
BEGIN DEBUG SESSION t1
t1 test A begin
"line A"
t1 test A end

BEGIN DEBUG SESSION t2
t2 test B begin
"line B"
t2 test B end |}]

0 comments on commit bc45506

Please sign in to comment.