Untested: uncurried syntax for binary primitive ops (%cd) and derived…

… operations (%op)
ahrefs · Jan 28, 2025 · b1e31fd · b1e31fd
1 parent bcd89d3
commit b1e31fd
Show file tree

Hide file tree

Showing 2 changed files with 22 additions and 2 deletions.
diff --git a/lib/ppx_cd.ml b/lib/ppx_cd.ml
@@ -923,6 +923,12 @@ let translate (expr : expression) : result =
           [%e? lhs]
           ([%e? rhs] ~projections:[%e? projections])] ->
         process_assign_unop ~accu_op ~lhs ~un_op:"id" ~rhs ~projections ~proj_in_scope:true ()
+    | [%expr
+        [%e? { pexp_desc = Pexp_ident { txt = Lident accu_op; _ }; _ }]
+          [%e? lhs]
+          ([%e? { pexp_desc = Pexp_ident { txt = Lident bin_op; _ }; _ }]
+             ([%e? rhs1], [%e? rhs2])
+             ~logic:[%e? { pexp_desc = Pexp_constant (Pconst_string (spec, s_loc, _)); _ } as logic])]
     | [%expr
         [%e? { pexp_desc = Pexp_ident { txt = Lident accu_op; _ }; _ }]
           [%e? lhs]
@@ -981,6 +987,10 @@ let translate (expr : expression) : result =
         in
         let _, un_op = Hashtbl.find_exn unary_ops unop_ident loc in
         process_raw_unop ~accu_op ~lhs ~un_op ~rhs ~logic
+    | [%expr
+        [%e? { pexp_desc = Pexp_ident { txt = Lident accu_op; _ }; _ }]
+          [%e? lhs]
+          ([%e? { pexp_desc = Pexp_ident { txt = Lident bin_op; _ }; _ }] ([%e? rhs1], [%e? rhs2]))]
     | [%expr
         [%e? { pexp_desc = Pexp_ident { txt = Lident accu_op; _ }; _ }]
           [%e? lhs]
@@ -1003,6 +1013,10 @@ let translate (expr : expression) : result =
     | [%expr [%e? { pexp_desc = Pexp_ident { txt = Lident accu_op; _ }; _ }] [%e? lhs] [%e? rhs]]
       when is_assignment accu_op && proj_in_scope ->
         process_assign_unop ~accu_op ~lhs ~un_op:"id" ~rhs ~proj_in_scope ()
+    | [%expr
+        [%e? { pexp_desc = Pexp_ident { txt = Lident accu_op; _ }; _ }]
+          [%e? lhs]
+          ([%e? { pexp_desc = Pexp_ident { txt = Lident bin_op; _ }; _ }] ([%e? rhs1], [%e? rhs2]))]
     | [%expr
         [%e? { pexp_desc = Pexp_ident { txt = Lident accu_op; _ }; _ }]
           [%e? lhs]

diff --git a/lib/ppx_op.ml b/lib/ppx_op.ml
@@ -157,6 +157,13 @@ let rec translate ~num_configs ~is_toplevel ~has_config ?label expr =
       lift_config_vb ~loop ~num_configs ?label ~expr1 ~c_expr [ expr2 ]
   | [%expr [%e? expr1] ~config:[%e? c_expr]] ->
       lift_config_vb ~loop ~num_configs ?label ~expr1 ~c_expr []
+  | [%expr
+      [%e? { pexp_desc = Pexp_ident { txt = Lident op_ident; _ }; _ }] ([%e? expr2], [%e? expr3])]
+    when Hashtbl.mem binary_ops op_ident ->
+      let e1 = [%expr [%e expr] ?label:[%e opt_expr ~loc label]] in
+      let vbs2, e2 = loop expr2 in
+      let vbs3, e3 = loop expr3 in
+      (reduce_vbss [ vbs2; vbs3 ], [%expr [%e e1] [%e e2] [%e e3]])
   | [%expr [%e? expr1] [%e? expr2] [%e? expr3]] ->
       let vbs1, e1 = loop ?label expr1 in
       let vbs2, e2 = loop expr2 in
@@ -260,8 +267,7 @@ let rec translate ~num_configs ~is_toplevel ~has_config ?label expr =
       let vbs, body = loop ?label body in
       (vbs, { expr with pexp_desc = Pexp_letmodule (name, module_expr, body) })
   | { pexp_desc = Pexp_ident { txt = Lident op_ident; _ }; _ }
-    when is_primitive_op op_ident || is_operator op_ident
-    ->
+    when is_primitive_op op_ident || is_operator op_ident ->
       (* FIXME: this heuristic is hacky... *)
       (no_vbs, [%expr [%e expr] ?label:[%e opt_expr ~loc label]])
   | expr -> (no_vbs, expr)