From 7824ae74e94b767739026005210476c642c93b86 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= <jerome.vouillon@gmail.com>
Date: Tue, 27 Oct 2026 13:20:27 +0100
Subject: [PATCH] ppx_devtools.optcomp: gate patterns in the cases of a
 function

With OxCaml's ppxlib, the cases of a function are mapped with
[self#list self#case] rather than [self#cases], so the [@if] attributes
on their patterns were not evaluated. Gated cases are now dropped from
[case], by raising an exception caught in [list]. Matching on
[Pfunction_cases] directly is not an option, as it does not exist in
ppxlib before 0.36.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
---
 optcomp/ppx_devtools_optcomp.ml | 25 +++++++++++++++++--------
 test/test_expect_light.ml       | 16 ++++++++++++++++
 2 files changed, 33 insertions(+), 8 deletions(-)

diff --git a/optcomp/ppx_devtools_optcomp.ml b/optcomp/ppx_devtools_optcomp.ml
index 90a0107..6c0e058 100644
--- a/optcomp/ppx_devtools_optcomp.ml
+++ b/optcomp/ppx_devtools_optcomp.ml
@@ -152,6 +152,8 @@ let truncate_floating_str items =
   in
   loop items
 
+exception Drop_case
+
 let traverse =
   object (self)
     inherit Ppxlib.Ast_traverse.map as super
@@ -192,14 +194,21 @@ let traverse =
           | _ -> { item with pstr_desc = Pstr_value (r, l) })
       | _ -> item
 
-    method! cases cases =
-      let cases =
-        filter_map cases ~f:(fun case ->
-            match filter_pattern case.pc_lhs with
-            | None -> None
-            | Some pattern -> Some { case with pc_lhs = pattern })
-      in
-      super#cases cases
+    (* Match cases are not always traversed through [cases]: with OxCaml's
+       ppxlib, the cases of a [function] are mapped with [self#list
+       self#case]. So [case] raises [Drop_case] when its pattern is gated
+       out, and [list] removes the corresponding element. *)
+    method! list : 'a. ('a -> 'a) -> 'a list -> 'a list =
+      fun f l ->
+        filter_map l ~f:(fun x ->
+            match f x with
+            | x -> Some x
+            | exception Drop_case -> None)
+
+    method! case case =
+      match filter_pattern case.pc_lhs with
+      | None -> raise Drop_case
+      | Some pattern -> super#case { case with pc_lhs = pattern }
 
     method! signature_item item =
       let item = super#signature_item item in
diff --git a/test/test_expect_light.ml b/test/test_expect_light.ml
index 1fce6eb..7a51d33 100644
--- a/test/test_expect_light.ml
+++ b/test/test_expect_light.ml
@@ -44,6 +44,22 @@ let%expect_test "gated away" =
   [%expect {| deliberately wrong |}]
 [@@if ocaml_version < (4, 0, 0)]
 
+(* Gated patterns, in the cases of a match and of a function. *)
+let%expect_test "gated patterns" =
+  let f x =
+    match x with
+    | (1 [@if ocaml_version < (4, 0, 0)]) -> "gated"
+    | 1 | (2 [@if ocaml_version < (4, 0, 0)]) -> "one"
+    | _ -> "other"
+  in
+  let g = function
+    | (1 [@if ocaml_version < (4, 0, 0)]) -> "gated"
+    | 1 | (2 [@if ocaml_version < (4, 0, 0)]) -> "one"
+    | _ -> "other"
+  in
+  Printf.printf "%s %s %s %s" (f 1) (f 2) (g 1) (g 2);
+  [%expect {| one other one other |}]
+
 let%expect_test "extension axes" =
   print_string "extended";
   [%expect ({| boolean axis |} [@when disabled])];