Fix failure of 'lift_map_with_context' in traverse by compile-time evaluation of 'fst' and 'snd'

CHANGES.md

@@ -11,6 +11,9 @@ unreleased
 
 - Make quoter `let` binding non-recursive (#401, @sim642)
 
+- Fix failure of 'lift_map_with_context' in traverse by compile-time
+  evaluation of 'fst' and 'snd' (#390, @smuenzel)
+
 0.29.1 (14/02/2023)
 ------------------
 

test/traverse/test.ml

@@ -82,3 +82,58 @@ class virtual iter :
     method t : t -> unit
   end
 |}]
+
+type t = Inline of { a : string option; b : t }
+[@@deriving traverse]
+[%%expect{|
+type t = Inline of { a : string option; b : t; }
+class virtual map :
+  object
+    method virtual option : ('a -> 'a) -> 'a option -> 'a option
+    method virtual string : string -> string
+    method t : t -> t
+  end
+class virtual iter :
+  object
+    method virtual option : ('a -> unit) -> 'a option -> unit
+    method virtual string : string -> unit
+    method t : t -> unit
+  end
+class virtual ['acc] fold :
+  object
+    method virtual option : ('a -> 'acc -> 'acc) -> 'a option -> 'acc -> 'acc
+    method virtual string : string -> 'acc -> 'acc
+    method t : t -> 'acc -> 'acc
+  end
+class virtual ['acc] fold_map :
+  object
+    method virtual option :
+      ('a -> 'acc -> 'a * 'acc) -> 'a option -> 'acc -> 'a option * 'acc
+    method virtual string : string -> 'acc -> string * 'acc
+    method t : t -> 'acc -> t * 'acc
+  end
+class virtual ['ctx] map_with_context :
+  object
+    method virtual option :
+      ('ctx -> 'a -> 'a) -> 'ctx -> 'a option -> 'a option
+    method virtual string : 'ctx -> string -> string
+    method t : 'ctx -> t -> t
+  end
+class virtual ['res] lift :
+  object
+    method virtual constr : string -> 'res list -> 'res
+    method virtual option : ('a -> 'res) -> 'a option -> 'res
+    method virtual record : (string * 'res) list -> 'res
+    method virtual string : string -> 'res
+    method t : t -> 'res
+  end
+class virtual ['ctx, 'res] lift_map_with_context :
+  object
+    method virtual constr : 'ctx -> string -> 'res list -> 'res
+    method virtual option :
+      ('ctx -> 'a -> 'a * 'res) -> 'ctx -> 'a option -> 'a option * 'res
+    method virtual record : 'ctx -> (string * 'res) list -> 'res
+    method virtual string : 'ctx -> string -> string * 'res
+    method t : 'ctx -> t -> t * 'res
+  end
+|}]

traverse/ppxlib_traverse.ml

@@ -16,8 +16,16 @@ let tvar_of_var { txt; loc } = ptyp_var ~loc txt
 let evars_of_vars = List.map ~f:evar_of_var
 let pvars_of_vars = List.map ~f:pvar_of_var
 let tvars_of_vars = List.map ~f:tvar_of_var
-let fst_expr ~loc expr = [%expr Stdlib.fst [%e expr]]
-let snd_expr ~loc expr = [%expr Stdlib.snd [%e expr]]
+
+let fst_expr ~loc expr =
+  match expr.pexp_desc with
+  | Pexp_tuple [ fst; _ ] -> fst
+  | _ -> [%expr Stdlib.fst [%e expr]]
+
+let snd_expr ~loc expr =
+  match expr.pexp_desc with
+  | Pexp_tuple [ _; snd ] -> snd
+  | _ -> [%expr Stdlib.snd [%e expr]]
 
 let methods_of_class_exn = function
   | {