Support ppxlib.0.36.0

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"}

dune-project

@@ -1,2 +1,2 @@
-(lang dune 2.7)
+(lang dune 2.9)
 (cram enable)

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

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
 

test/instrument/dune

@@ -1,3 +1,5 @@
 (cram
- (deps test.sh)
+ (deps
+  test.sh
+  (package bisect_ppx))
  (alias compatible))

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!
+

test/instrument/recent/dune

@@ -1,2 +1,2 @@
 (cram
- (deps ../test.sh))
+  (deps ../test.sh (package bisect_ppx)))