From 6eaf032eaebbb3fec2cf8213ffc5161e24a7f855 Mon Sep 17 00:00:00 2001 From: Hyeseong Kim Date: Sat, 28 Sep 2024 10:49:11 +0900 Subject: [PATCH] PoC: generic infix operators --- compiler/core/lam_convert.ml | 11 + compiler/ml/lambda.ml | 4 + compiler/ml/lambda.mli | 4 + compiler/ml/printlambda.ml | 2 + compiler/ml/translcore.ml | 242 +++++---- compiler/ml/typecore.ml | 467 ++++++++++-------- runtime/pervasives.res | 4 +- runtime/rescript.json | 2 +- .../math_operator_constant.res.expected | 10 +- .../expected/math_operator_int.res.expected | 20 - .../math_operator_string.res.expected | 16 - .../expected/primitives1.res.expected | 18 +- .../super_errors/expected/type1.res.expected | 18 +- tests/tests/src/generic_infix_test.js | 37 ++ tests/tests/src/generic_infix_test.res | 9 + 15 files changed, 470 insertions(+), 394 deletions(-) create mode 100644 tests/tests/src/generic_infix_test.js create mode 100644 tests/tests/src/generic_infix_test.res diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 74131236ab..fcfa102098 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -232,6 +232,7 @@ let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = | Pduprecord -> prim ~primitive:Pduprecord ~args loc | Plazyforce -> prim ~primitive:Plazyforce ~args loc | Praise _ -> prim ~primitive:Praise ~args loc + | Pinfix _ -> assert false | Pobjcomp x -> prim ~primitive:(Pobjcomp x) ~args loc | Pobjorder -> prim ~primitive:Pobjorder ~args loc | Pobjmin -> prim ~primitive:Pobjmin ~args loc @@ -475,6 +476,16 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : | Lprim (Pimport, args, loc) -> let args = Ext_list.map args (convert_aux ~dynamic_import:true) in lam_prim ~primitive:Pimport ~args loc + | Lprim (Pinfix (Inf_custom (mod_, op)), args, loc) -> + let fn = Lam.var (Ident.create_persistent op) in + let args = Ext_list.map args (convert_aux ~dynamic_import) in + let ap_info : Lam.ap_info = + {ap_loc = loc; ap_status = App_na; ap_inlined = Lambda.Default_inline} + in + Lam.apply fn args ap_info + | Lprim (Pinfix Inf_invariant, args, loc) -> + (* TODO : invariant *) + assert false | Lprim (primitive, args, loc) -> let args = Ext_list.map args (convert_aux ~dynamic_import) in lam_prim ~primitive ~args loc diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index fcd1dc86ca..857cfa991f 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -175,6 +175,8 @@ type immediate_or_pointer = Immediate | Pointer type is_safe = Safe | Unsafe +type infix_info = Inf_custom of string * string | Inf_invariant + type primitive = | Pidentity | Pignore @@ -198,6 +200,8 @@ type primitive = | Pccall of Primitive.description (* Exceptions *) | Praise of raise_kind + (* Infix *) + | Pinfix of infix_info (* object operations *) | Pobjcomp of comparison | Pobjorder diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 7f506ac62d..e2605c3029 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -138,6 +138,8 @@ type pointer_info = | Pt_shape_none | Pt_assertfalse +type infix_info = Inf_custom of string * string | Inf_invariant + type primitive = | Pidentity | Pignore @@ -161,6 +163,8 @@ type primitive = | Pccall of Primitive.description (* Exceptions *) | Praise of raise_kind + (* Infix *) + | Pinfix of infix_info (* object primitives *) | Pobjcomp of comparison | Pobjorder diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index 4512355c34..a01b305dfc 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -125,6 +125,8 @@ let primitive ppf = function | Plazyforce -> fprintf ppf "force" | Pccall p -> fprintf ppf "%s" p.prim_name | Praise k -> fprintf ppf "%s" (Lambda.raise_kind k) + | Pinfix (Inf_custom (mod_, op)) -> fprintf ppf "%s.%s" mod_ op + | Pinfix Inf_invariant -> fprintf ppf "invariant" | Pobjcomp Ceq -> fprintf ppf "==" | Pobjcomp Cneq -> fprintf ppf "!=" | Pobjcomp Clt -> fprintf ppf "<" diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 4b080b5f14..021ed69965 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -50,157 +50,182 @@ let transl_extension_constructor env path ext = (* Translation of primitives *) type specialized = { - objcomp: Lambda.primitive; - intcomp: Lambda.primitive; - boolcomp: Lambda.primitive; - floatcomp: Lambda.primitive; - stringcomp: Lambda.primitive; - bigintcomp: Lambda.primitive; + obj: Lambda.primitive; + int: Lambda.primitive; + bool: Lambda.primitive; + float: Lambda.primitive; + string: Lambda.primitive; + bigint: Lambda.primitive; simplify_constant_constructor: bool; } +let infix_table = + create_hashtable + [| + ( "%add", + { + obj = Paddint; + int = Paddint; + bool = Pinfix Inf_invariant; + float = Paddfloat; + string = Pstringadd; + bigint = Paddbigint; + simplify_constant_constructor = false; + } ); + ( "%sub", + { + obj = Paddint; + int = Psubint; + bool = Pinfix Inf_invariant; + float = Psubfloat; + string = Pinfix Inf_invariant; + bigint = Psubbigint; + simplify_constant_constructor = false; + } ); + |] + let comparisons_table = create_hashtable [| ( "%equal", { - objcomp = Pobjcomp Ceq; - intcomp = Pintcomp Ceq; - boolcomp = Pboolcomp Ceq; - floatcomp = Pfloatcomp Ceq; - stringcomp = Pstringcomp Ceq; - bigintcomp = Pbigintcomp Ceq; + obj = Pobjcomp Ceq; + int = Pintcomp Ceq; + bool = Pboolcomp Ceq; + float = Pfloatcomp Ceq; + string = Pstringcomp Ceq; + bigint = Pbigintcomp Ceq; simplify_constant_constructor = true; } ); ( "%notequal", { - objcomp = Pobjcomp Cneq; - intcomp = Pintcomp Cneq; - boolcomp = Pboolcomp Cneq; - floatcomp = Pfloatcomp Cneq; - stringcomp = Pstringcomp Cneq; - bigintcomp = Pbigintcomp Cneq; + obj = Pobjcomp Cneq; + int = Pintcomp Cneq; + bool = Pboolcomp Cneq; + float = Pfloatcomp Cneq; + string = Pstringcomp Cneq; + bigint = Pbigintcomp Cneq; simplify_constant_constructor = true; } ); ( "%lessthan", { - objcomp = Pobjcomp Clt; - intcomp = Pintcomp Clt; - boolcomp = Pboolcomp Clt; - floatcomp = Pfloatcomp Clt; - stringcomp = Pstringcomp Clt; - bigintcomp = Pbigintcomp Clt; + obj = Pobjcomp Clt; + int = Pintcomp Clt; + bool = Pboolcomp Clt; + float = Pfloatcomp Clt; + string = Pstringcomp Clt; + bigint = Pbigintcomp Clt; simplify_constant_constructor = false; } ); ( "%greaterthan", { - objcomp = Pobjcomp Cgt; - intcomp = Pintcomp Cgt; - boolcomp = Pboolcomp Cgt; - floatcomp = Pfloatcomp Cgt; - stringcomp = Pstringcomp Cgt; - bigintcomp = Pbigintcomp Cgt; + obj = Pobjcomp Cgt; + int = Pintcomp Cgt; + bool = Pboolcomp Cgt; + float = Pfloatcomp Cgt; + string = Pstringcomp Cgt; + bigint = Pbigintcomp Cgt; simplify_constant_constructor = false; } ); ( "%lessequal", { - objcomp = Pobjcomp Cle; - intcomp = Pintcomp Cle; - boolcomp = Pboolcomp Cle; - floatcomp = Pfloatcomp Cle; - stringcomp = Pstringcomp Cle; - bigintcomp = Pbigintcomp Cle; + obj = Pobjcomp Cle; + int = Pintcomp Cle; + bool = Pboolcomp Cle; + float = Pfloatcomp Cle; + string = Pstringcomp Cle; + bigint = Pbigintcomp Cle; simplify_constant_constructor = false; } ); ( "%greaterequal", { - objcomp = Pobjcomp Cge; - intcomp = Pintcomp Cge; - boolcomp = Pboolcomp Cge; - floatcomp = Pfloatcomp Cge; - stringcomp = Pstringcomp Cge; - bigintcomp = Pbigintcomp Cge; + obj = Pobjcomp Cge; + int = Pintcomp Cge; + bool = Pboolcomp Cge; + float = Pfloatcomp Cge; + string = Pstringcomp Cge; + bigint = Pbigintcomp Cge; simplify_constant_constructor = false; } ); ( "%compare", { - objcomp = Pobjorder; - intcomp = Pintorder; - boolcomp = Pboolorder; - floatcomp = Pfloatorder; - stringcomp = Pstringorder; - bigintcomp = Pbigintorder; + obj = Pobjorder; + int = Pintorder; + bool = Pboolorder; + float = Pfloatorder; + string = Pstringorder; + bigint = Pbigintorder; simplify_constant_constructor = false; } ); ( "%max", { - objcomp = Pobjmax; - intcomp = Pintmax; - boolcomp = Pboolmax; - floatcomp = Pboolmax; - stringcomp = Pstringmax; - bigintcomp = Pbigintmax; + obj = Pobjmax; + int = Pintmax; + bool = Pboolmax; + float = Pboolmax; + string = Pstringmax; + bigint = Pbigintmax; simplify_constant_constructor = false; } ); ( "%min", { - objcomp = Pobjmin; - intcomp = Pintmin; - boolcomp = Pboolmin; - floatcomp = Pfloatmin; - stringcomp = Pstringmin; - bigintcomp = Pbigintmin; + obj = Pobjmin; + int = Pintmin; + bool = Pboolmin; + float = Pfloatmin; + string = Pstringmin; + bigint = Pbigintmin; simplify_constant_constructor = false; } ); ( "%equal_null", { - objcomp = Pobjcomp Ceq; - intcomp = Pintcomp Ceq; - boolcomp = Pboolcomp Ceq; - floatcomp = Pfloatcomp Ceq; - stringcomp = Pstringcomp Ceq; - bigintcomp = Pbigintcomp Ceq; + obj = Pobjcomp Ceq; + int = Pintcomp Ceq; + bool = Pboolcomp Ceq; + float = Pfloatcomp Ceq; + string = Pstringcomp Ceq; + bigint = Pbigintcomp Ceq; simplify_constant_constructor = false; } ); ( "%equal_undefined", { - objcomp = Pobjcomp Ceq; - intcomp = Pintcomp Ceq; - boolcomp = Pboolcomp Ceq; - floatcomp = Pfloatcomp Ceq; - stringcomp = Pstringcomp Ceq; - bigintcomp = Pbigintcomp Ceq; + obj = Pobjcomp Ceq; + int = Pintcomp Ceq; + bool = Pboolcomp Ceq; + float = Pfloatcomp Ceq; + string = Pstringcomp Ceq; + bigint = Pbigintcomp Ceq; simplify_constant_constructor = false; } ); ( "%equal_nullable", { - objcomp = Pobjcomp Ceq; - intcomp = Pintcomp Ceq; - boolcomp = Pboolcomp Ceq; - floatcomp = Pfloatcomp Ceq; - stringcomp = Pstringcomp Ceq; - bigintcomp = Pbigintcomp Ceq; + obj = Pobjcomp Ceq; + int = Pintcomp Ceq; + bool = Pboolcomp Ceq; + float = Pfloatcomp Ceq; + string = Pstringcomp Ceq; + bigint = Pbigintcomp Ceq; simplify_constant_constructor = false; } ); (* FIXME: Core compatibility *) ( "%bs_min", { - objcomp = Pobjmax; - intcomp = Pintmax; - boolcomp = Pboolmax; - floatcomp = Pboolmax; - stringcomp = Pstringmax; - bigintcomp = Pbigintmax; + obj = Pobjmax; + int = Pintmax; + bool = Pboolmax; + float = Pboolmax; + string = Pstringmax; + bigint = Pbigintmax; simplify_constant_constructor = false; } ); ( "%bs_max", { - objcomp = Pobjmin; - intcomp = Pintmin; - boolcomp = Pboolmin; - floatcomp = Pfloatmin; - stringcomp = Pstringmin; - bigintcomp = Pbigintmin; + obj = Pobjmin; + int = Pintmin; + bool = Pboolmin; + float = Pfloatmin; + string = Pstringmin; + bigint = Pbigintmin; simplify_constant_constructor = false; } ); |] @@ -375,31 +400,36 @@ let primitives_table = let find_primitive prim_name = Hashtbl.find primitives_table prim_name -let specialize_comparison - ({objcomp; intcomp; floatcomp; stringcomp; bigintcomp; boolcomp} : - specialized) env ty = +let specialize_op ({obj; int; float; string; bigint; bool} : specialized) env ty + = match () with | () when is_base_type env ty Predef.path_int || is_base_type env ty Predef.path_char || maybe_pointer_type env ty = Immediate -> - intcomp - | () when is_base_type env ty Predef.path_float -> floatcomp - | () when is_base_type env ty Predef.path_string -> stringcomp - | () when is_base_type env ty Predef.path_bigint -> bigintcomp - | () when is_base_type env ty Predef.path_bool -> boolcomp - | () -> objcomp + int + | () when is_base_type env ty Predef.path_float -> float + | () when is_base_type env ty Predef.path_string -> string + | () when is_base_type env ty Predef.path_bigint -> bigint + | () when is_base_type env ty Predef.path_bool -> bool + | () -> obj (* Specialize a primitive from available type information, raise Not_found if primitive is unknown *) let specialize_primitive p env ty (* ~has_constant_constructor *) = try - let table = Hashtbl.find comparisons_table p.prim_name in + let table = Hashtbl.find infix_table p.prim_name in match is_function_type env ty with - | Some (lhs, _rhs) -> specialize_comparison table env lhs - | None -> table.objcomp - with Not_found -> find_primitive p.prim_name + | Some (lhs, _rhs) -> specialize_op table env lhs + | None -> table.obj + with Not_found -> ( + try + let table = Hashtbl.find comparisons_table p.prim_name in + match is_function_type env ty with + | Some (lhs, _rhs) -> specialize_op table env lhs + | None -> table.obj + with Not_found -> find_primitive p.prim_name) (* Eta-expand a primitive *) @@ -463,7 +493,9 @@ let transl_primitive_application loc prim env ty args = | [arg1; _] when is_base_type env arg1.exp_type Predef.path_bool && Hashtbl.mem comparisons_table prim_name -> - (Hashtbl.find comparisons_table prim_name).boolcomp + (Hashtbl.find comparisons_table prim_name).bool + | [arg1; _] when Hashtbl.mem infix_table prim_name -> + specialize_op (Hashtbl.find infix_table prim_name) env arg1.exp_type | _ -> let has_constant_constructor = match args with @@ -476,7 +508,7 @@ let transl_primitive_application loc prim env ty args = in if has_constant_constructor then match Hashtbl.find_opt comparisons_table prim_name with - | Some table when table.simplify_constant_constructor -> table.intcomp + | Some table when table.simplify_constant_constructor -> table.int | Some _ | None -> specialize_primitive prim env ty (* ~has_constant_constructor*) else specialize_primitive prim env ty diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 3499b5f7e5..b254ebb673 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -3562,232 +3562,263 @@ and is_automatic_curried_application env funct = and type_application ?type_clash_context uncurried env funct (sargs : sargs) : targs * Types.type_expr * bool = - (* funct.exp_type may be generic *) - let result_type omitted ty_fun = - List.fold_left - (fun ty_fun (l, ty, lv) -> newty2 lv (Tarrow (l, ty, ty_fun, Cok))) - ty_fun omitted - in - let has_label l ty_fun = - let ls, tvar = list_labels env ty_fun in - tvar || List.mem l ls - in - let ignored = ref [] in - let has_uncurried_type t = - match (expand_head env t).desc with - | Tconstr (Pident {name = "function$"}, [t; t_arity], _) -> - let arity = Ast_uncurried.type_to_arity t_arity in - Some (arity, t) - | _ -> None + let is_generic_infix path = + match Path.name path with + | "Pervasives.+" | "Pervasives.-" -> true + | _ -> false in - let force_uncurried_type funct = - match has_uncurried_type funct.exp_type with - | None -> ( - let arity = List.length sargs in - let uncurried_typ = - Ast_uncurried.make_uncurried_type ~env ~arity (newvar ()) - in - match (expand_head env funct.exp_type).desc with - | Tvar _ | Tarrow _ -> unify_exp env funct uncurried_typ + 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 | _ -> - raise - (Error - ( funct.exp_loc, - env, - Apply_non_function (expand_head env funct.exp_type) ))) - | Some _ -> () - in - let extract_uncurried_type t = - match has_uncurried_type t with - | Some (arity, t1) -> - if List.length sargs > arity then - raise - (Error - ( funct.exp_loc, - env, - Uncurried_arity_mismatch (t, arity, List.length sargs) )); - (t1, arity) - | None -> (t, max_int) - in - let update_uncurried_arity ~nargs t new_t = - match has_uncurried_type t with - | Some (arity, _) -> - let newarity = arity - nargs in - let fully_applied = newarity <= 0 in - if uncurried && not fully_applied then - raise - (Error - ( funct.exp_loc, - env, - Uncurried_arity_mismatch (t, arity, List.length sargs) )); - let new_t = - if fully_applied then new_t - else Ast_uncurried.make_uncurried_type ~env ~arity:newarity new_t - in - (fully_applied, new_t) - | _ -> (false, new_t) - in - let rec type_unknown_args max_arity ~(args : lazy_args) omitted ty_fun - (syntax_args : sargs) : targs * _ = - match syntax_args with - | [] -> - let collect_args () = - ( List.map - (function - | l, None -> (l, None) - | l, Some f -> (l, Some (f ()))) - (List.rev args), - instance env (result_type omitted ty_fun) ) - in - if List.length args < max_arity && uncurried then - match (expand_head env ty_fun).desc with - | Tarrow (Optional l, t1, t2, _) -> - ignored := (Optional l, t1, ty_fun.level) :: !ignored; - let arg = - ( Optional l, - Some (fun () -> option_none (instance env t1) Location.none) ) - in - type_unknown_args max_arity ~args:(arg :: args) omitted t2 [] - | _ -> collect_args () - else collect_args () - | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})] - when uncurried && omitted = [] && args <> [] - && List.length args = List.length !ignored -> - (* foo(. ) treated as empty application if all args are optional (hence ignored) *) - type_unknown_args max_arity ~args omitted ty_fun [] - | (l1, sarg1) :: sargl -> - let ty1, ty2 = - let ty_fun = expand_head env ty_fun in - let arity_ok = List.length args < max_arity in - match ty_fun.desc with - | Tvar _ -> - let t1 = newvar () and t2 = newvar () in - if ty_fun.level >= t1.level && not_identity funct.exp_desc then - Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument; - unify env ty_fun (newty (Tarrow (l1, t1, t2, Clink (ref Cunknown)))); - (t1, t2) - | Tarrow (l, t1, t2, _) when Asttypes.same_arg_label l l1 && arity_ok -> - (t1, t2) - | td -> ( - let ty_fun = - match td with - | Tarrow _ -> newty td - | _ -> ty_fun - in - let ty_res = result_type (omitted @ !ignored) ty_fun in - match ty_res.desc with - | Tarrow _ -> - if not arity_ok then + 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 + (targs, result_type, true) + | _ -> ( + (* funct.exp_type may be generic *) + let result_type omitted ty_fun = + List.fold_left + (fun ty_fun (l, ty, lv) -> newty2 lv (Tarrow (l, ty, ty_fun, Cok))) + ty_fun omitted + in + let has_label l ty_fun = + let ls, tvar = list_labels env ty_fun in + tvar || List.mem l ls + in + let ignored = ref [] in + let has_uncurried_type t = + match (expand_head env t).desc with + | Tconstr (Pident {name = "function$"}, [t; t_arity], _) -> + let arity = Ast_uncurried.type_to_arity t_arity in + Some (arity, t) + | _ -> None + in + let force_uncurried_type funct = + match has_uncurried_type funct.exp_type with + | None -> ( + let arity = List.length sargs in + let uncurried_typ = + Ast_uncurried.make_uncurried_type ~env ~arity (newvar ()) + in + match (expand_head env funct.exp_type).desc with + | Tvar _ | Tarrow _ -> unify_exp env funct uncurried_typ + | _ -> + raise + (Error + ( funct.exp_loc, + env, + Apply_non_function (expand_head env funct.exp_type) ))) + | Some _ -> () + in + let extract_uncurried_type t = + match has_uncurried_type t with + | Some (arity, t1) -> + if List.length sargs > arity then + raise + (Error + ( funct.exp_loc, + env, + Uncurried_arity_mismatch (t, arity, List.length sargs) )); + (t1, arity) + | None -> (t, max_int) + in + let update_uncurried_arity ~nargs t new_t = + match has_uncurried_type t with + | Some (arity, _) -> + let newarity = arity - nargs in + let fully_applied = newarity <= 0 in + if uncurried && not fully_applied then + raise + (Error + ( funct.exp_loc, + env, + Uncurried_arity_mismatch (t, arity, List.length sargs) )); + let new_t = + if fully_applied then new_t + else Ast_uncurried.make_uncurried_type ~env ~arity:newarity new_t + in + (fully_applied, new_t) + | _ -> (false, new_t) + in + let rec type_unknown_args max_arity ~(args : lazy_args) omitted ty_fun + (syntax_args : sargs) : targs * _ = + match syntax_args with + | [] -> + let collect_args () = + ( List.map + (function + | l, None -> (l, None) + | l, Some f -> (l, Some (f ()))) + (List.rev args), + instance env (result_type omitted ty_fun) ) + in + if List.length args < max_arity && uncurried then + match (expand_head env ty_fun).desc with + | Tarrow (Optional l, t1, t2, _) -> + ignored := (Optional l, t1, ty_fun.level) :: !ignored; + let arg = + ( Optional l, + Some (fun () -> option_none (instance env t1) Location.none) ) + in + type_unknown_args max_arity ~args:(arg :: args) omitted t2 [] + | _ -> collect_args () + else collect_args () + | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})] + when uncurried && omitted = [] && args <> [] + && List.length args = List.length !ignored -> + (* foo(. ) treated as empty application if all args are optional (hence ignored) *) + type_unknown_args max_arity ~args omitted ty_fun [] + | (l1, sarg1) :: sargl -> + let ty1, ty2 = + let ty_fun = expand_head env ty_fun in + let arity_ok = List.length args < max_arity in + match ty_fun.desc with + | Tvar _ -> + let t1 = newvar () and t2 = newvar () in + if ty_fun.level >= t1.level && not_identity funct.exp_desc then + Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument; + unify env ty_fun (newty (Tarrow (l1, t1, t2, Clink (ref Cunknown)))); + (t1, t2) + | Tarrow (l, t1, t2, _) when Asttypes.same_arg_label l l1 && arity_ok + -> + (t1, t2) + | td -> ( + let ty_fun = + match td with + | Tarrow _ -> newty td + | _ -> ty_fun + in + let ty_res = result_type (omitted @ !ignored) ty_fun in + match ty_res.desc with + | Tarrow _ -> + if not arity_ok then + raise + (Error + ( sarg1.pexp_loc, + env, + Apply_wrong_label (l1, funct.exp_type) )) + else if not (has_label l1 ty_fun) then + raise + (Error (sarg1.pexp_loc, env, Apply_wrong_label (l1, ty_res))) + else raise (Error (funct.exp_loc, env, Incoherent_label_order)) + | _ -> raise (Error - (sarg1.pexp_loc, env, Apply_wrong_label (l1, funct.exp_type))) - else if not (has_label l1 ty_fun) then - raise - (Error (sarg1.pexp_loc, env, Apply_wrong_label (l1, ty_res))) - else raise (Error (funct.exp_loc, env, Incoherent_label_order)) - | _ -> - raise - (Error - ( funct.exp_loc, - env, - Apply_non_function (expand_head env funct.exp_type) ))) - in - let optional = is_optional l1 in - let arg1 () = - let arg1 = type_expect env sarg1 ty1 in - if optional then unify_exp env arg1 (type_option (newvar ())); - arg1 - in - type_unknown_args max_arity ~args:((l1, Some arg1) :: args) omitted ty2 - sargl - in - let rec type_args ?type_clash_context max_arity args omitted ~ty_fun ty_fun0 - ~(sargs : sargs) = - match (expand_head env ty_fun, expand_head env ty_fun0) with - | ( {desc = Tarrow (l, ty, ty_fun, com); level = lv}, - {desc = Tarrow (_, ty0, ty_fun0, _)} ) - when sargs <> [] && commu_repr com = Cok && List.length args < max_arity - -> - let name = label_name l and optional = is_optional l in - let sargs, omitted, arg = - match extract_label name sargs with - | None -> - if optional && (uncurried || label_assoc Nolabel sargs) then ( - ignored := (l, ty, lv) :: !ignored; + ( funct.exp_loc, + env, + Apply_non_function (expand_head env funct.exp_type) ))) + in + let optional = is_optional l1 in + let arg1 () = + let arg1 = type_expect env sarg1 ty1 in + if optional then unify_exp env arg1 (type_option (newvar ())); + arg1 + in + type_unknown_args max_arity ~args:((l1, Some arg1) :: args) omitted ty2 + sargl + in + let rec type_args ?type_clash_context max_arity args omitted ~ty_fun ty_fun0 + ~(sargs : sargs) = + match (expand_head env ty_fun, expand_head env ty_fun0) with + | ( {desc = Tarrow (l, ty, ty_fun, com); level = lv}, + {desc = Tarrow (_, ty0, ty_fun0, _)} ) + when sargs <> [] && commu_repr com = Cok && List.length args < max_arity + -> + let name = label_name l and optional = is_optional l in + let sargs, omitted, arg = + match extract_label name sargs with + | None -> + if optional && (uncurried || label_assoc Nolabel sargs) then ( + ignored := (l, ty, lv) :: !ignored; + ( sargs, + omitted, + Some (fun () -> option_none (instance env ty) Location.none) )) + else (sargs, (l, ty, lv) :: omitted, None) + | Some (l', sarg0, sargs) -> + if (not optional) && is_optional l' then + Location.prerr_warning sarg0.pexp_loc + (Warnings.Nonoptional_label (Printtyp.string_of_label l)); ( sargs, omitted, - Some (fun () -> option_none (instance env ty) Location.none) )) - else (sargs, (l, ty, lv) :: omitted, None) - | Some (l', sarg0, sargs) -> - if (not optional) && is_optional l' then - Location.prerr_warning sarg0.pexp_loc - (Warnings.Nonoptional_label (Printtyp.string_of_label l)); - ( sargs, - omitted, - Some - (if (not optional) || is_optional l' then fun () -> - type_argument - ?type_clash_context: - (type_clash_context_for_function_argument - type_clash_context sarg0) - env sarg0 ty ty0 - else fun () -> - option_some - (type_argument ?type_clash_context env sarg0 - (extract_option_type env ty) - (extract_option_type env ty0))) ) - in - type_args ?type_clash_context max_arity ((l, arg) :: args) omitted ~ty_fun - ty_fun0 ~sargs - | _ -> - type_unknown_args max_arity ~args omitted ty_fun0 - sargs (* This is the hot path for non-labeled function*) - in - let () = - let ls, tvar = list_labels env funct.exp_type in - if not tvar then - let labels = Ext_list.filter ls (fun l -> not (is_optional l)) in - if - Ext_list.same_length labels sargs - && List.for_all (fun (l, _) -> l = Nolabel) sargs - && List.exists (fun l -> l <> Nolabel) labels - then - raise - (Error - ( funct.exp_loc, - env, - Labels_omitted - (List.map Printtyp.string_of_label - (Ext_list.filter labels (fun x -> x <> Nolabel))) )) - in - match sargs with - (* Special case for ignore: avoid discarding warning *) - | [(Nolabel, sarg)] when is_ignore funct env -> - let ty_arg, ty_res = - filter_arrow env (instance env funct.exp_type) Nolabel - in - let exp = type_expect env sarg ty_arg in - (match (expand_head env exp.exp_type).desc with - | Tarrow _ -> - Location.prerr_warning exp.exp_loc Warnings.Partial_application - | Tvar _ -> - Delayed_checks.add_delayed_check (fun () -> - check_application_result env false exp) - | _ -> ()); - ([(Nolabel, Some exp)], ty_res, false) - | _ -> - if uncurried then force_uncurried_type funct; - let ty, max_arity = extract_uncurried_type funct.exp_type in - let targs, ret_t = - type_args ?type_clash_context max_arity [] [] ~ty_fun:ty (instance env ty) - ~sargs + Some + (if (not optional) || is_optional l' then fun () -> + type_argument + ?type_clash_context: + (type_clash_context_for_function_argument + type_clash_context sarg0) + env sarg0 ty ty0 + else fun () -> + option_some + (type_argument ?type_clash_context env sarg0 + (extract_option_type env ty) + (extract_option_type env ty0))) ) + in + type_args ?type_clash_context max_arity ((l, arg) :: args) omitted + ~ty_fun ty_fun0 ~sargs + | _ -> + type_unknown_args max_arity ~args omitted ty_fun0 + sargs (* This is the hot path for non-labeled function*) in - let fully_applied, ret_t = - update_uncurried_arity funct.exp_type - ~nargs:(List.length !ignored + List.length sargs) - ret_t + let () = + let ls, tvar = list_labels env funct.exp_type in + if not tvar then + let labels = Ext_list.filter ls (fun l -> not (is_optional l)) in + if + Ext_list.same_length labels sargs + && List.for_all (fun (l, _) -> l = Nolabel) sargs + && List.exists (fun l -> l <> Nolabel) labels + then + raise + (Error + ( funct.exp_loc, + env, + Labels_omitted + (List.map Printtyp.string_of_label + (Ext_list.filter labels (fun x -> x <> Nolabel))) )) in - (targs, ret_t, fully_applied) + match sargs with + (* Special case for ignore: avoid discarding warning *) + | [(Nolabel, sarg)] when is_ignore funct env -> + let ty_arg, ty_res = + filter_arrow env (instance env funct.exp_type) Nolabel + in + let exp = type_expect env sarg ty_arg in + (match (expand_head env exp.exp_type).desc with + | Tarrow _ -> + Location.prerr_warning exp.exp_loc Warnings.Partial_application + | Tvar _ -> + Delayed_checks.add_delayed_check (fun () -> + check_application_result env false exp) + | _ -> ()); + ([(Nolabel, Some exp)], ty_res, false) + | _ -> + if uncurried then force_uncurried_type funct; + let ty, max_arity = extract_uncurried_type funct.exp_type in + let targs, ret_t = + type_args ?type_clash_context max_arity [] [] ~ty_fun:ty + (instance env ty) ~sargs + in + let fully_applied, ret_t = + update_uncurried_arity funct.exp_type + ~nargs:(List.length !ignored + List.length sargs) + ret_t + in + (targs, ret_t, fully_applied)) and type_construct env loc lid sarg ty_expected attrs = let opath = diff --git a/runtime/pervasives.res b/runtime/pervasives.res index 603d2d811a..ca1c1fdcbd 100644 --- a/runtime/pervasives.res +++ b/runtime/pervasives.res @@ -68,8 +68,8 @@ module Pervasives = { external \"~+": int => int = "%identity" external succ: int => int = "%succint" external pred: int => int = "%predint" - external \"+": (int, int) => int = "%addint" - external \"-": (int, int) => int = "%subint" + external \"+": ('a, 'a) => 'a = "%add" + external \"-": ('a, 'a) => 'a = "%sub" external \"*": (int, int) => int = "%mulint" external \"/": (int, int) => int = "%divint" external mod: (int, int) => int = "%modint" diff --git a/runtime/rescript.json b/runtime/rescript.json index 2ec055d9db..b9e194db8f 100644 --- a/runtime/rescript.json +++ b/runtime/rescript.json @@ -19,4 +19,4 @@ "-w -3+50", "-warn-error A" ] -} \ No newline at end of file +} diff --git a/tests/build_tests/super_errors/expected/math_operator_constant.res.expected b/tests/build_tests/super_errors/expected/math_operator_constant.res.expected index f2251eee15..741b07af7a 100644 --- a/tests/build_tests/super_errors/expected/math_operator_constant.res.expected +++ b/tests/build_tests/super_errors/expected/math_operator_constant.res.expected @@ -7,14 +7,8 @@ 3 │ let x = num + 12. 4 │ - This value has type: float - But it's being used with the + operator, which works on: int - - Floats and ints have their own mathematical operators. This means you cannot add a float and an int without converting between the two. - - Possible solutions: - - Ensure all values in this calculation has the type int. You can convert between floats and ints via Belt.Float.toInt and Belt.Int.fromFloat. - - Make 12. an int by removing the dot or explicitly converting to int + This has type: float + But it's expected to have type: int You can convert float to int with Belt.Float.toInt. If this is a literal, try a number without a trailing dot (e.g. 20). \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/math_operator_int.res.expected b/tests/build_tests/super_errors/expected/math_operator_int.res.expected index ebccfbecb7..e69de29bb2 100644 --- a/tests/build_tests/super_errors/expected/math_operator_int.res.expected +++ b/tests/build_tests/super_errors/expected/math_operator_int.res.expected @@ -1,20 +0,0 @@ - - We've found a bug for you! - /.../fixtures/math_operator_int.res:3:9-11 - - 1 │ let num = 0. - 2 │ - 3 │ let x = num + 12. - 4 │ - - This has type: float - But it's being used with the + operator, which works on: int - - Floats and ints have their own mathematical operators. This means you cannot add a float and an int without converting between the two. - - Possible solutions: - - Ensure all values in this calculation has the type int. You can convert between floats and ints via Belt.Float.toInt and Belt.Int.fromFloat. - - Change the operator to +., which works on float - - You can convert float to int with Belt.Float.toInt. - If this is a literal, try a number without a trailing dot (e.g. 20). \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/math_operator_string.res.expected b/tests/build_tests/super_errors/expected/math_operator_string.res.expected index cb03dfac3a..e69de29bb2 100644 --- a/tests/build_tests/super_errors/expected/math_operator_string.res.expected +++ b/tests/build_tests/super_errors/expected/math_operator_string.res.expected @@ -1,16 +0,0 @@ - - We've found a bug for you! - /.../fixtures/math_operator_string.res:1:9-15 - - 1 │ let x = "hello" + "what" - 2 │ - - This has type: string - But it's being used with the + operator, which works on: int - - Are you looking to concatenate strings? Use the operator ++, which concatenates strings. - - Possible solutions: - - Change the + operator to ++ to concatenate strings instead. - - You can convert string to int with Belt.Int.fromString. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/primitives1.res.expected b/tests/build_tests/super_errors/expected/primitives1.res.expected index b1a303eccb..cc2946f160 100644 --- a/tests/build_tests/super_errors/expected/primitives1.res.expected +++ b/tests/build_tests/super_errors/expected/primitives1.res.expected @@ -1,19 +1,13 @@ We've found a bug for you! - /.../fixtures/primitives1.res:2:1-2 + /.../fixtures/primitives1.res:2:6 1 │ /* got float, wanted int */ - 2 │ 2. + 2 + 2 │ 2. + 2 3 │ - This value has type: float - But it's being used with the + operator, which works on: int - - Floats and ints have their own mathematical operators. This means you cannot add a float and an int without converting between the two. - - Possible solutions: - - Ensure all values in this calculation has the type int. You can convert between floats and ints via Belt.Float.toInt and Belt.Int.fromFloat. - - Make 2. an int by removing the dot or explicitly converting to int + This has type: int + But it's expected to have type: float - You can convert float to int with Belt.Float.toInt. - If this is a literal, try a number without a trailing dot (e.g. 20). \ No newline at end of file + You can convert int to float with Belt.Int.toFloat. + If this is a literal, try a number with a trailing dot (e.g. 20.). \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/type1.res.expected b/tests/build_tests/super_errors/expected/type1.res.expected index 036daa2550..6bc3692c57 100644 --- a/tests/build_tests/super_errors/expected/type1.res.expected +++ b/tests/build_tests/super_errors/expected/type1.res.expected @@ -1,18 +1,12 @@ We've found a bug for you! - /.../fixtures/type1.res:1:9-10 + /.../fixtures/type1.res:1:14 - 1 │ let x = 2. + 2 + 1 │ let x = 2. + 2 2 │ - This value has type: float - But it's being used with the + operator, which works on: int - - Floats and ints have their own mathematical operators. This means you cannot add a float and an int without converting between the two. - - Possible solutions: - - Ensure all values in this calculation has the type int. You can convert between floats and ints via Belt.Float.toInt and Belt.Int.fromFloat. - - Make 2. an int by removing the dot or explicitly converting to int + This has type: int + But it's expected to have type: float - You can convert float to int with Belt.Float.toInt. - If this is a literal, try a number without a trailing dot (e.g. 20). \ No newline at end of file + You can convert int to float with Belt.Int.toFloat. + If this is a literal, try a number with a trailing dot (e.g. 20.). \ No newline at end of file diff --git a/tests/tests/src/generic_infix_test.js b/tests/tests/src/generic_infix_test.js new file mode 100644 index 0000000000..bffccc60d4 --- /dev/null +++ b/tests/tests/src/generic_infix_test.js @@ -0,0 +1,37 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE +'use strict'; + + +let float = 1 + 2; + +let string = "12"; + +let bigint = 1n + 2n; + +function addint(a, b) { + return a + b | 0; +} + +function addfloat(a, b) { + return a + b; +} + +function addbigint(a, b) { + return a + b; +} + +function addstring(a, b) { + return 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; +/* No side effect */ diff --git a/tests/tests/src/generic_infix_test.res b/tests/tests/src/generic_infix_test.res new file mode 100644 index 0000000000..fccf697ab7 --- /dev/null +++ b/tests/tests/src/generic_infix_test.res @@ -0,0 +1,9 @@ +let int = 1 + 2 +let float = 1. + 2. +let string = "1" + "2" +let bigint = 1n + 2n + +let addint = (a, b) => a + b +let addfloat = (a: float, b) => a + b +let addbigint = (a: bigint, b) => a + b +let addstring = (a: string, b) => a + b