From f35fdf4bdcb82c308d70f7c9c313a77777f54bdf Mon Sep 17 00:00:00 2001 From: Patrick Ferris Date: Fri, 20 Jun 2025 12:21:20 +0100 Subject: [PATCH 1/7] Support ppxlib.0.36.0 --- src/ppx/instrument.ml | 79 +++++++++++++++++++++++++------------------ 1 file changed, 46 insertions(+), 33 deletions(-) diff --git a/src/ppx/instrument.ml b/src/ppx/instrument.ml index 7a300336..bd727115 100644 --- a/src/ppx/instrument.ml +++ b/src/ppx/instrument.ml @@ -1314,38 +1314,32 @@ class instrumenter = instrument_expr ~use_loc_of:e ~post:true (Exp.assert_ e_new) (* Expressions that have subexpressions that might not get visited. *) - | Pexp_function cases -> - traverse_cases ~is_in_tail_position:true cases - >>| fun cases_new -> - let cases, _, _, need_binding = instrument_cases cases_new in - if need_binding then - Exp.fun_ ~loc ~attrs - Ppxlib.Nolabel None ([%pat? ___bisect_matched_value___]) - (Exp.match_ ~loc - ([%expr ___bisect_matched_value___]) cases) - else - Exp.function_ ~loc ~attrs cases - - | Pexp_fun (label, default_value, p, e) -> - begin match default_value with - | None -> - return None - | Some e -> - traverse ~is_in_tail_position:false e - >>| fun e -> - Some (instrument_expr e) - end - >>= fun default_value -> - traverse ~is_in_tail_position:true e - >>| fun e -> - let e = - match e.pexp_desc with - | Pexp_function _ | Pexp_fun _ -> e - | Pexp_constraint (e', t) -> - {e with pexp_desc = Pexp_constraint (instrument_expr e', t)} - | _ -> instrument_expr e + | Pexp_function (params, constraint_, body) -> + let open Parsetree in + let new_params = + List.map (function + | { pparam_desc = Pparam_val (lbl, Some default_value, c); _ } as p -> + traverse ~is_in_tail_position:false default_value + >>| fun e -> { p with pparam_desc = Pparam_val (lbl, Some (instrument_expr e), c) } + | e -> return e + ) params + in + Ppxlib.With_errors.combine_errors new_params + >>= fun new_params -> + + traverse_function_body ~is_in_tail_position:true body + >>| fun new_body -> + let new_body = + match new_body with + | Pfunction_body { pexp_desc = Pexp_function _; _ } -> new_body + | Pfunction_body { pexp_desc = Pexp_constraint (e', t); _ } -> + Pfunction_body {e with pexp_desc = Pexp_constraint (instrument_expr e', t)} + | Pfunction_body e -> Pfunction_body (instrument_expr e) + | Pfunction_cases _ as cases -> cases in - Exp.fun_ ~loc ~attrs label default_value p e + + let e = Ast_builder.Default.pexp_function ~loc new_params constraint_ new_body in + { e with pexp_attributes = attrs } | Pexp_match (e, cases) -> traverse_cases ~is_in_tail_position cases @@ -1418,7 +1412,7 @@ class instrumenter = | Pexp_lazy e -> let rec is_trivial_syntactic_value e = match e.Parsetree.pexp_desc with - | Pexp_function _ | Pexp_fun _ | Pexp_poly _ | Pexp_ident _ + | Pexp_function _ | Pexp_poly _ | Pexp_ident _ | Pexp_constant _ | Pexp_construct (_, None) -> true | Pexp_constraint (e, _) | Pexp_coerce (e, _, _) -> @@ -1446,7 +1440,7 @@ class instrumenter = >>| fun e -> let e = match e.pexp_desc with - | Pexp_function _ | Pexp_fun _ -> e + | Pexp_function _ -> e | _ -> instrument_expr e in Exp.poly ~loc ~attrs e t @@ -1654,6 +1648,25 @@ class instrumenter = end |> collect_errors + and traverse_function_body ~is_in_tail_position body = + let open Ppxlib in + match body with + | Pfunction_body e -> + traverse ~is_in_tail_position e + >>| fun e -> Pfunction_body e + | Pfunction_cases (cases, loc, attrs) -> + traverse_cases ~is_in_tail_position:true cases + >>| fun cases_new -> + let cases, _, _, need_binding = instrument_cases cases_new in + if need_binding then + Pfunction_body + (Exp.fun_ ~loc ~attrs + Ppxlib.Nolabel None ([%pat? ___bisect_matched_value___]) + (Exp.match_ ~loc + ([%expr ___bisect_matched_value___]) cases)) + else + Pfunction_cases (cases, loc, attrs) + in traverse ~is_in_tail_position:false e From 07bfceec652773de4b140cebc236a15e2429809e Mon Sep 17 00:00:00 2001 From: Nathan Rebours Date: Thu, 18 Sep 2025 15:01:30 +0200 Subject: [PATCH 2/7] Add regression test for function_cases instrumentation bug Signed-off-by: Nathan Rebours --- bisect_ppx.opam | 2 +- dune-project | 2 +- test/instrument/dune | 4 +++- test/instrument/function.t | 38 ++++++++++++++++++++++++++++++++++++++ 4 files changed, 43 insertions(+), 3 deletions(-) create mode 100644 test/instrument/function.t diff --git a/bisect_ppx.opam b/bisect_ppx.opam index 77a20062..b1b2bea3 100644 --- a/bisect_ppx.opam +++ b/bisect_ppx.opam @@ -20,7 +20,7 @@ maintainer: [ depends: [ "base-unix" "cmdliner" {>= "1.0.0"} - "dune" {>= "2.7.0"} + "dune" {>= "2.9.0"} "ocaml" {>= "4.03.0"} "ppxlib" {>= "0.28.0"} diff --git a/dune-project b/dune-project index e1e4354c..ae730292 100644 --- a/dune-project +++ b/dune-project @@ -1,2 +1,2 @@ -(lang dune 2.7) +(lang dune 2.9) (cram enable) diff --git a/test/instrument/dune b/test/instrument/dune index a29f94bf..49a57bbb 100644 --- a/test/instrument/dune +++ b/test/instrument/dune @@ -1,3 +1,5 @@ (cram - (deps test.sh) + (deps + test.sh + (package bisect_ppx)) (alias compatible)) diff --git a/test/instrument/function.t b/test/instrument/function.t new file mode 100644 index 00000000..bc706c51 --- /dev/null +++ b/test/instrument/function.t @@ -0,0 +1,38 @@ +This is a regression test for #450: https://github.com/aantron/bisect_ppx/issues/450 + + $ cat > dune-project <<'EOF' + > (lang dune 2.7) + > EOF + + $ cat > dune <<'EOF' + > (library + > (name lib) + > (modules lib) + > (instrumentation (backend bisect_ppx))) + > + > (test + > (name test) + > (libraries lib) + > (modules test)) + > EOF + + $ cat > lib.ml <<'EOF' + > let is_hex_digit = function '0' .. '9' | 'a' .. 'f' -> true | _ -> false + > EOF + + $ cat > test.ml <<'EOF' + > let () = + > if Lib.is_hex_digit '1' then begin + > Printf.printf "Test success!"; + > exit 0 + > end else + > Printf.printf "Test failure!"; + > exit 1 + > EOF + + $ dune runtest --instrument-with bisect_ppx + File "lib.ml", line 1, characters 19-72: + 1 | let is_hex_digit = function '0' .. '9' | 'a' .. 'f' -> true | _ -> false + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + Error: broken invariant in parsetree: Function without any value parameters + [1] From 4f0cb2a2e1b0b786b6b5f1c94985b201aa012f12 Mon Sep 17 00:00:00 2001 From: Nathan Rebours Date: Thu, 18 Sep 2025 15:33:15 +0200 Subject: [PATCH 3/7] Fix instrumentation of [function _ ->] expressions Signed-off-by: Nathan Rebours --- src/ppx/instrument.ml | 25 +++++++++++++++---------- test/instrument/function.t | 6 +----- 2 files changed, 16 insertions(+), 15 deletions(-) diff --git a/src/ppx/instrument.ml b/src/ppx/instrument.ml index bd727115..884b2d29 100644 --- a/src/ppx/instrument.ml +++ b/src/ppx/instrument.ml @@ -1327,8 +1327,8 @@ class instrumenter = Ppxlib.With_errors.combine_errors new_params >>= fun new_params -> - traverse_function_body ~is_in_tail_position:true body - >>| fun new_body -> + traverse_function_body ~is_in_tail_position:true ~params:new_params body + >>| fun (new_body, new_params) -> let new_body = match new_body with | Pfunction_body { pexp_desc = Pexp_function _; _ } -> new_body @@ -1648,24 +1648,29 @@ class instrumenter = end |> collect_errors - and traverse_function_body ~is_in_tail_position body = + and traverse_function_body ~is_in_tail_position ~params body = let open Ppxlib in match body with | Pfunction_body e -> traverse ~is_in_tail_position e - >>| fun e -> Pfunction_body e + >>| fun e -> (Pfunction_body e, params) | Pfunction_cases (cases, loc, attrs) -> traverse_cases ~is_in_tail_position:true cases >>| fun cases_new -> let cases, _, _, need_binding = instrument_cases cases_new in if need_binding then - Pfunction_body - (Exp.fun_ ~loc ~attrs - Ppxlib.Nolabel None ([%pat? ___bisect_matched_value___]) - (Exp.match_ ~loc - ([%expr ___bisect_matched_value___]) cases)) + let extra_param = + Ast_builder.Default.pparam_val ~loc Nolabel None + [%pat? ___bisect_matched_value___] + in + let body = + Pfunction_body + (Exp.match_ ~loc + ([%expr ___bisect_matched_value___]) cases) + in + (body, params @ [extra_param]) else - Pfunction_cases (cases, loc, attrs) + (Pfunction_cases (cases, loc, attrs), params) in diff --git a/test/instrument/function.t b/test/instrument/function.t index bc706c51..6441de3d 100644 --- a/test/instrument/function.t +++ b/test/instrument/function.t @@ -31,8 +31,4 @@ This is a regression test for #450: https://github.com/aantron/bisect_ppx/issues > EOF $ dune runtest --instrument-with bisect_ppx - File "lib.ml", line 1, characters 19-72: - 1 | let is_hex_digit = function '0' .. '9' | 'a' .. 'f' -> true | _ -> false - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - Error: broken invariant in parsetree: Function without any value parameters - [1] + Test success! From 3134448549d8a3882663fd8cd000e332bdb7aab5 Mon Sep 17 00:00:00 2001 From: Anton Bachin Date: Sun, 12 Oct 2025 17:05:43 +0300 Subject: [PATCH 4/7] opam: update ppxlib constraint --- bisect_ppx.opam | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/bisect_ppx.opam b/bisect_ppx.opam index b1b2bea3..ab792c70 100644 --- a/bisect_ppx.opam +++ b/bisect_ppx.opam @@ -22,7 +22,7 @@ depends: [ "cmdliner" {>= "1.0.0"} "dune" {>= "2.9.0"} "ocaml" {>= "4.03.0"} - "ppxlib" {>= "0.28.0"} + "ppxlib" {>= "0.36.0"} "dune" {with-test & >= "3.0.0"} "ocamlformat" {with-test & = "0.16.0"} From ebb352612bf32d74f26a9318dc668a54872b0cad Mon Sep 17 00:00:00 2001 From: Patrick Ferris Date: Tue, 21 Oct 2025 10:05:54 +0100 Subject: [PATCH 5/7] Catch function cases earlier in instrumentation --- src/ppx/instrument.ml | 9 ++++++++- test/instrument/control/newtype.t | 3 ++- test/instrument/recent/dune | 2 +- 3 files changed, 11 insertions(+), 3 deletions(-) diff --git a/src/ppx/instrument.ml b/src/ppx/instrument.ml index 884b2d29..fe862384 100644 --- a/src/ppx/instrument.ml +++ b/src/ppx/instrument.ml @@ -1313,6 +1313,13 @@ class instrumenter = >>| fun e_new -> instrument_expr ~use_loc_of:e ~post:true (Exp.assert_ e_new) + (* The case where we have [function A -> ... | B -> ...] *) + | Pexp_function ([], constraint_, (Pfunction_cases _ as cases)) -> + traverse_function_body ~is_in_tail_position ~params:[] cases + >>| fun (new_body, new_params) -> + let e = Ast_builder.Default.pexp_function ~loc new_params constraint_ new_body in + { e with pexp_attributes = attrs } + (* Expressions that have subexpressions that might not get visited. *) | Pexp_function (params, constraint_, body) -> let open Parsetree in @@ -1440,7 +1447,7 @@ class instrumenter = >>| fun e -> let e = match e.pexp_desc with - | Pexp_function _ -> e + | Pexp_function ([], _, Pfunction_cases _) -> e | _ -> instrument_expr e in Exp.poly ~loc ~attrs e t diff --git a/test/instrument/control/newtype.t b/test/instrument/control/newtype.t index 630a122d..5ff92689 100644 --- a/test/instrument/control/newtype.t +++ b/test/instrument/control/newtype.t @@ -12,7 +12,8 @@ Recursive instrumentation of subexpression. > let _ = fun (type _t) -> fun x -> x > EOF let _ = - fun (type _t) x -> + fun (type _t) -> + fun x -> ___bisect_visit___ 0; x diff --git a/test/instrument/recent/dune b/test/instrument/recent/dune index 6327a6c3..3f973651 100644 --- a/test/instrument/recent/dune +++ b/test/instrument/recent/dune @@ -1,2 +1,2 @@ (cram - (deps ../test.sh)) + (deps ../test.sh (package bisect_ppx))) From a0ff8cf6ea06d7f052c8d0fceac92a42d57e7809 Mon Sep 17 00:00:00 2001 From: Nathan Rebours Date: Tue, 4 Nov 2025 17:24:58 +0100 Subject: [PATCH 6/7] Add regression test for @AllanBlanchard instrumentation bug Signed-off-by: Nathan Rebours --- test/instrument/function.t | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) diff --git a/test/instrument/function.t b/test/instrument/function.t index 6441de3d..a94fd856 100644 --- a/test/instrument/function.t +++ b/test/instrument/function.t @@ -32,3 +32,30 @@ This is a regression test for #450: https://github.com/aantron/bisect_ppx/issues $ dune runtest --instrument-with bisect_ppx Test success! + +This is a regression test for https://github.com/aantron/bisect_ppx/pull/448#issuecomment-3477888423 + + $ cat > lib.ml << EOF + > let is_hex_digit (f : bool -> bool) : char -> bool = function + > | '0' .. '9' | 'a' .. 'f' -> f true + > | _ -> f false + > EOF + + $ cat > test.ml <<'EOF' + > let () = + > if Lib.is_hex_digit (fun x -> x) '1' then begin + > Printf.printf "Test success!"; + > exit 0 + > end else + > Printf.printf "Test failure!"; + > exit 1 + > EOF + + $ dune runtest --instrument-with bisect_ppx + File "lib.ml", line 2, characters 31-37: + 2 | | '0' .. '9' | 'a' .. 'f' -> f true + ^^^^^^ + Error: This expression has type bool but an expression was expected of type + char -> bool + [1] + From a64e135a91b6fedbc25c743816b6208f7e5874c4 Mon Sep 17 00:00:00 2001 From: Nathan Rebours Date: Tue, 4 Nov 2025 17:53:26 +0100 Subject: [PATCH 7/7] Fix instrumentation of Pexp_function Signed-off-by: Nathan Rebours --- src/ppx/instrument.ml | 35 ++++++++++++++++++++--------------- test/instrument/function.t | 7 +------ 2 files changed, 21 insertions(+), 21 deletions(-) diff --git a/src/ppx/instrument.ml b/src/ppx/instrument.ml index fe862384..f147da1c 100644 --- a/src/ppx/instrument.ml +++ b/src/ppx/instrument.ml @@ -1315,10 +1315,14 @@ class instrumenter = (* The case where we have [function A -> ... | B -> ...] *) | Pexp_function ([], constraint_, (Pfunction_cases _ as cases)) -> - traverse_function_body ~is_in_tail_position ~params:[] cases - >>| fun (new_body, new_params) -> - let e = Ast_builder.Default.pexp_function ~loc new_params constraint_ new_body in - { e with pexp_attributes = attrs } + traverse_function_body ~is_in_tail_position cases + >>| fun new_body -> + (match (new_body : Parsetree.function_body) with + | Pfunction_body e -> + { e with pexp_attributes = attrs } + | Pfunction_cases _ -> + let e = Ast_builder.Default.pexp_function ~loc [] constraint_ new_body in + { e with pexp_attributes = attrs }) (* Expressions that have subexpressions that might not get visited. *) | Pexp_function (params, constraint_, body) -> @@ -1334,8 +1338,8 @@ class instrumenter = Ppxlib.With_errors.combine_errors new_params >>= fun new_params -> - traverse_function_body ~is_in_tail_position:true ~params:new_params body - >>| fun (new_body, new_params) -> + traverse_function_body ~is_in_tail_position:true body + >>| fun new_body -> let new_body = match new_body with | Pfunction_body { pexp_desc = Pexp_function _; _ } -> new_body @@ -1655,12 +1659,12 @@ class instrumenter = end |> collect_errors - and traverse_function_body ~is_in_tail_position ~params body = + and traverse_function_body ~is_in_tail_position body = let open Ppxlib in match body with | Pfunction_body e -> traverse ~is_in_tail_position e - >>| fun e -> (Pfunction_body e, params) + >>| fun e -> Pfunction_body e | Pfunction_cases (cases, loc, attrs) -> traverse_cases ~is_in_tail_position:true cases >>| fun cases_new -> @@ -1670,14 +1674,15 @@ class instrumenter = Ast_builder.Default.pparam_val ~loc Nolabel None [%pat? ___bisect_matched_value___] in - let body = - Pfunction_body - (Exp.match_ ~loc - ([%expr ___bisect_matched_value___]) cases) - in - (body, params @ [extra_param]) + Pfunction_body + (Ast_builder.Default.pexp_function ~loc + [extra_param] + None + (Pfunction_body + (Exp.match_ ~loc + ([%expr ___bisect_matched_value___]) cases))) else - (Pfunction_cases (cases, loc, attrs), params) + Pfunction_cases (cases, loc, attrs) in diff --git a/test/instrument/function.t b/test/instrument/function.t index a94fd856..d8db1c5e 100644 --- a/test/instrument/function.t +++ b/test/instrument/function.t @@ -52,10 +52,5 @@ This is a regression test for https://github.com/aantron/bisect_ppx/pull/448#iss > EOF $ dune runtest --instrument-with bisect_ppx - File "lib.ml", line 2, characters 31-37: - 2 | | '0' .. '9' | 'a' .. 'f' -> f true - ^^^^^^ - Error: This expression has type bool but an expression was expected of type - char -> bool - [1] + Test success!