Fix failure of 'lift_map_with_context' in traverse by compile-time ev…

…aluation of

'fst' and 'snd'

Signed-off-by: Stefan Muenzel <[email protected]>

test/traverse/test.ml

@@ -88,6 +88,54 @@ type t =
   | Arrow of { label : string option; domain : t; range : t }
 [@@deriving traverse]
 [%%expect{|
-Line _, characters 2-61:
-Error: This constructor expects an inlined record argument.
+type t = X | Arrow of { label : string option; domain : t; range : 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
   | {