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 6441de3d..d8db1c5e 100644 --- a/test/instrument/function.t +++ b/test/instrument/function.t @@ -32,3 +32,25 @@ 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 + Test success! +