1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
|
From: =?utf-8?q?St=C3=A9phane_Glondu?= <glondu@debian.org>
Date: Wed, 24 Sep 2025 11:08:12 +0200
Subject: Add ppxlib 0.36.0 support
Origin: https://github.com/aantron/bisect_ppx/pull/448
---
src/ppx/instrument.ml | 84 +++++++++++++++++++++++++++++++--------------------
1 file changed, 51 insertions(+), 33 deletions(-)
diff --git a/src/ppx/instrument.ml b/src/ppx/instrument.ml
index 7a30033..884b2d2 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
- Exp.fun_ ~loc ~attrs label default_value p e
+ 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) ->
+ 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
+
+ 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,30 @@ class instrumenter =
end
|> collect_errors
+ 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, 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
+ 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), params)
+
in
traverse ~is_in_tail_position:false e
|
