rewrite type translation

compiler/ml/translcore.ml

@@ -49,6 +49,15 @@ let transl_extension_constructor env path ext =
 
 (* Translation of primitives *)
 
+(*
+type sargs = (Asttypes.arg_label * Parsetree.expression) list
+
+let translate_unified_application (env : Env.t) (prim : Primitive.description)
+    (sargs : sargs) : Lambda.primitive option =
+  (* TODO *)
+  None
+*)
+
 type specialized = {
   obj: Lambda.primitive;
   int: Lambda.primitive;

compiler/ml/typecore.ml

@@ -2458,8 +2458,8 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp
     in
     let type_clash_context = type_clash_context_from_function sexp sfunct in
     let args, ty_res, fully_applied =
-      match specialized_infix_type_application env funct sargs with
-      | Some application -> application
+      match translate_unified_application env funct sargs with
+      | Some (targs, result_type) -> (targs, result_type, true)
       | None -> type_application ?type_clash_context uncurried env funct sargs
     in
     end_def ();
@@ -3563,35 +3563,96 @@ and is_automatic_curried_application env funct =
   | Tarrow _ -> true
   | _ -> false
 
-and specialized_infix_type_application env funct (sargs : sargs) :
-    (targs * Types.type_expr * bool) option =
-  let is_generic_infix path =
-    match Path.name path with
-    | "Pervasives.+" | "Pervasives.-" -> true
-    | _ -> false
-  in
-  match (funct.exp_desc, sargs) with
-  | Texp_ident (path, _, _), [(Nolabel, lhs_expr); (Nolabel, rhs_expr)]
-    when is_generic_infix path ->
-    let lhs = type_exp env lhs_expr in
-    let lhs_type = lhs.exp_type in
-    let rhs =
-      match (expand_head env lhs_type).desc with
-      | Tconstr (path, _, _) when Path.same path Predef.path_int ->
-        type_expect env rhs_expr Predef.type_int
-      | Tconstr (path, _, _) when Path.same path Predef.path_float ->
-        type_expect env rhs_expr Predef.type_float
-      | Tconstr (path, _, _) when Path.same path Predef.path_bigint ->
-        type_expect env rhs_expr Predef.type_bigint
-      | Tconstr (path, _, _) when Path.same path Predef.path_string ->
-        type_expect env rhs_expr Predef.type_string
-      | _ ->
-        unify env lhs_type Predef.type_int;
-        type_expect env rhs_expr Predef.type_int
-    in
-    let result_type = lhs_type in
-    let targs = [(Nolabel, Some lhs); (Nolabel, Some rhs)] in
-    Some (targs, result_type, true)
+and translate_unified_application (env : Env.t) (funct : Typedtree.expression)
+    (sargs : sargs) : (targs * Types.type_expr) option =
+  match funct.exp_desc with
+  | Texp_ident (path, _, _) -> (
+    let entry = Hashtbl.find_opt Unified_ops.index_by_path (Path.name path) in
+    match (entry, sargs) with
+    | Some {form = Unary; specialization; _}, [(Nolabel, lhs_expr)] ->
+      let lhs = type_exp env lhs_expr in
+      let lhs_type = expand_head env lhs.exp_type in
+      let result_type =
+        match (lhs_type.desc, specialization) with
+        | Tconstr (path, _, _), _ when Path.same path Predef.path_int ->
+          Predef.type_int
+        | Tconstr (path, _, _), {bool = Some _}
+          when Path.same path Predef.path_bool ->
+          Predef.type_bool
+        | Tconstr (path, _, _), {float = Some _}
+          when Path.same path Predef.path_float ->
+          Predef.type_float
+        | Tconstr (path, _, _), {bigint = Some _}
+          when Path.same path Predef.path_bigint ->
+          Predef.type_bigint
+        | Tconstr (path, _, _), {string = Some _}
+          when Path.same path Predef.path_string ->
+          Predef.type_string
+        | _ ->
+          unify env lhs_type Predef.type_int;
+          Predef.type_int
+      in
+      let targs = [(Nolabel, Some lhs)] in
+      Some (targs, result_type)
+    | ( Some {form = Binary; specialization; _},
+        [(Nolabel, lhs_expr); (Nolabel, rhs_expr)] ) ->
+      let lhs = type_exp env lhs_expr in
+      let lhs_type = expand_head env lhs.exp_type in
+      let rhs = type_exp env rhs_expr in
+      let rhs_type = expand_head env rhs.exp_type in
+      let lhs, rhs, result_type =
+        (* rule 1. *)
+        match (lhs_type.desc, specialization) with
+        | Tconstr (path, _, _), _ when Path.same path Predef.path_int ->
+          let rhs = type_expect env rhs_expr Predef.type_int in
+          (lhs, rhs, Predef.type_int)
+        | Tconstr (path, _, _), {bool = Some _}
+          when Path.same path Predef.path_bool ->
+          let rhs = type_expect env rhs_expr Predef.type_bool in
+          (lhs, rhs, Predef.type_bool)
+        | Tconstr (path, _, _), {float = Some _}
+          when Path.same path Predef.path_float ->
+          let rhs = type_expect env rhs_expr Predef.type_float in
+          (lhs, rhs, Predef.type_float)
+        | Tconstr (path, _, _), {bigint = Some _}
+          when Path.same path Predef.path_bigint ->
+          let rhs = type_expect env rhs_expr Predef.type_bigint in
+          (lhs, rhs, Predef.type_bigint)
+        | Tconstr (path, _, _), {string = Some _}
+          when Path.same path Predef.path_string ->
+          let rhs = type_expect env rhs_expr Predef.type_string in
+          (lhs, rhs, Predef.type_string)
+        | _ -> (
+          (* rule 2. *)
+          match (rhs_type.desc, specialization) with
+          | Tconstr (path, _, _), _ when Path.same path Predef.path_int ->
+            let lhs = type_expect env lhs_expr Predef.type_int in
+            (lhs, rhs, Predef.type_int)
+          | Tconstr (path, _, _), {bool = Some _}
+            when Path.same path Predef.path_bool ->
+            let lhs = type_expect env lhs_expr Predef.type_bool in
+            (lhs, rhs, Predef.type_bool)
+          | Tconstr (path, _, _), {float = Some _}
+            when Path.same path Predef.path_float ->
+            let lhs = type_expect env lhs_expr Predef.type_float in
+            (lhs, rhs, Predef.type_float)
+          | Tconstr (path, _, _), {bigint = Some _}
+            when Path.same path Predef.path_bigint ->
+            let lhs = type_expect env lhs_expr Predef.type_bigint in
+            (lhs, rhs, Predef.type_bigint)
+          | Tconstr (path, _, _), {string = Some _}
+            when Path.same path Predef.path_string ->
+            let lhs = type_expect env lhs_expr Predef.type_string in
+            (lhs, rhs, Predef.type_string)
+          | _ ->
+            (* rule 3. *)
+            let lhs = type_expect env lhs_expr Predef.type_int in
+            let rhs = type_expect env rhs_expr Predef.type_int in
+            (lhs, rhs, Predef.type_int))
+      in
+      let targs = [(Nolabel, Some lhs); (Nolabel, Some rhs)] in
+      Some (targs, result_type)
+    | _ -> None)
   | _ -> None
 
 and type_application ?type_clash_context uncurried env funct (sargs : sargs) :

compiler/ml/unified_ops.ml

@@ -1,47 +1,93 @@
-open Btype
-open Types
 open Misc
 
 (*
   Unified_ops is for specialization of some primitive operators.
 
   For example adding two values. We have `+` for ints, `+.` for floats, and `++` for strings.
-  That because we don't use implicit type conversion or overloading.
+  That because we don't allow implicit conversion or overloading for operations.
 
-  It is a fundamental property of the ReScript language, but at the same time it is far from the best DX we can think of, and it became a problem when introducing new primitives like bigint.
+  It is a fundamental property of the ReScript language, but it is far from the best DX we can think of,
+  and it became a problem when new primitives like bigint were introduced.
 
   See discussion: https://github.com/rescript-lang/rescript-compiler/issues/6525
 
-  1. Type level translation
+  Unified ops mitigate the problem by adding ad-hoc translation rules on applications of the core built-in operators
+  which have form of binary infix ('a -> 'a -> 'a) or unary ('a -> 'a)
 
-  2. IR level translation
-*)
+  Translation rules should be applied in its application, in both type-level and IR(lambda)-level.
 
-type args = (Asttypes.arg_label * Parsetree.expression) list
-type targs = (Asttypes.arg_label * Typedtree.expression option) list
+  The rules:
 
-type specialized_type = {
-  int: Path.t;
-  bool: Path.t option;
-  float: Path.t option;
-  bigint: Path.t option;
-  string: Path.t option;
-}
+  1. If the lhs type is a primitive type, unify the rhs and the result type to the lhs type.
+  2. If the lhs type is not a primitive type but the rhs type is, unify lhs and the result type to the rhs type.
+  3. If both lhs type and rhs type is not a primitive type, unify the whole types to the int. 
+
+  Since these are simple ad-hoc translations for primitive applications, we cannot use the result type defined in other contexts.
+  So falling back to int type is the simplest behavior that ensures backwards compatibility.
+*)
 
-let specialized_types = create_hashtable [||]
+type form = Unary | Binary
 
-type specialized_primitive = {
+type specialization = {
   int: Lambda.primitive;
   bool: Lambda.primitive option;
   float: Lambda.primitive option;
   bigint: Lambda.primitive option;
   string: Lambda.primitive option;
 }
 
-let translate_type_application (env : Env.t) (funct : Parsetree.expression)
-    (args : args) : (targs * type_expr) option =
-  None
+type entry = {
+  path: string;
+      (** TODO: Maybe it can be a Path.t in Predef instead of string *)
+  name: string;
+  form: form;
+  specialization: specialization;
+}
+
+let builtin x = Primitive_modules.pervasives ^ "." ^ x
+
+let entries =
+  [|
+    {
+      path = builtin "+";
+      name = "%add";
+      form = Binary;
+      specialization =
+        {
+          int = Paddint;
+          bool = None;
+          float = Some Paddfloat;
+          bigint = Some Paddbigint;
+          string = Some Pstringadd;
+        };
+    };
+    {
+      path = builtin "-";
+      name = "%sub";
+      form = Binary;
+      specialization =
+        {
+          int = Psubint;
+          bool = None;
+          float = Some Psubfloat;
+          bigint = Some Psubbigint;
+          string = None;
+        };
+    };
+  |]
 
-let translate_primitive_application (env : Env.t) (prim : Primitive.description)
-    (args : args) : Lambda.primitive option =
-  None
+let index_by_path =
+  entries |> Array.map (fun entry -> (entry.path, entry)) |> create_hashtable
+
+let index_by_name =
+  entries |> Array.map (fun entry -> (entry.name, entry)) |> create_hashtable
+
+(*
+  Actual implementations of translation are colocated into core modules
+
+  You can find it in:
+  - Type-level : ml/typecore.ml
+  - IR-level   : ml/translcore.ml
+
+  With function name "translate_unified_application"
+*)

compiler/ml/unified_ops.mli

@@ -0,0 +1,20 @@
+type form = Unary | Binary
+
+type specialization = {
+  int: Lambda.primitive;
+  bool: Lambda.primitive option;
+  float: Lambda.primitive option;
+  bigint: Lambda.primitive option;
+  string: Lambda.primitive option;
+}
+
+type entry = {
+  path: string;
+  name: string;
+  form: form;
+  specialization: specialization;
+}
+
+val index_by_path : (string, entry) Hashtbl.t
+
+val index_by_name : (string, entry) Hashtbl.t

tests/tests/src/generic_infix_test.js → tests/tests/src/generic_infix_test.mjs

@@ -1,5 +1,4 @@
 // Generated by ReScript, PLEASE EDIT WITH CARE
-'use strict';
 
 
 let float = 1 + 2;
@@ -26,12 +25,14 @@ function addstring(a, b) {
 
 let int = 3;
 
-exports.int = int;
-exports.float = float;
-exports.string = string;
-exports.bigint = bigint;
-exports.addint = addint;
-exports.addfloat = addfloat;
-exports.addbigint = addbigint;
-exports.addstring = addstring;
+export {
+  int,
+  float,
+  string,
+  bigint,
+  addint,
+  addfloat,
+  addbigint,
+  addstring,
+}
 /* No side effect */