diff --git a/bisect_ppx.opam b/bisect_ppx.opam index d7e57008..59f52efc 100644 --- a/bisect_ppx.opam +++ b/bisect_ppx.opam @@ -20,9 +20,9 @@ maintainer: [ depends: [ "base-unix" "cmdliner" {>= "1.3.0"} - "dune" {>= "2.7.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"} 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/src/ppx/instrument.ml b/src/ppx/instrument.ml index 7a300336..f147da1c 100644 --- a/src/ppx/instrument.ml +++ b/src/ppx/instrument.ml @@ -1313,39 +1313,44 @@ class instrumenter = >>| fun e_new -> 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 + (* The case where we have [function A -> ... | B -> ...] *) + | Pexp_function ([], constraint_, (Pfunction_cases _ as cases)) -> + 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 }) - | 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 + (* Expressions that have subexpressions that might not get visited. *) + | 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 +1423,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 +1451,7 @@ class instrumenter = >>| fun e -> let e = match e.pexp_desc with - | Pexp_function _ | Pexp_fun _ -> e + | Pexp_function ([], _, Pfunction_cases _) -> e | _ -> instrument_expr e in Exp.poly ~loc ~attrs e t @@ -1654,6 +1659,31 @@ 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 + let extra_param = + Ast_builder.Default.pparam_val ~loc Nolabel None + [%pat? ___bisect_matched_value___] + in + 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) + in traverse ~is_in_tail_position:false e 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/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..d8db1c5e --- /dev/null +++ b/test/instrument/function.t @@ -0,0 +1,56 @@ +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 + 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 + Test success! + 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)))