allow operator overloading on abstracts with @:op syntax (this may be subject to change)

ast.ml

@@ -39,6 +39,7 @@ module Meta = struct
 		| BuildXml
 		| Class
 		| ClassCode
+		| Commutative
 		| CompilerGenerated
 		| CoreApi
 		| CoreType
@@ -93,6 +94,7 @@ module Meta = struct
 		| NotNull
 		| NoUsing
 		| Ns
+		| Op
 		| Optional
 		| Overload
 		| Public
@@ -143,6 +145,7 @@ module Meta = struct
 		| BuildXml -> "buildXml"
 		| Class -> ":class"
 		| ClassCode -> ":classCode"
+		| Commutative -> ":commutative"
 		| CompilerGenerated -> ":compilerGenerated"
 		| CoreApi -> ":coreApi"
 		| CoreType -> ":coreType"
@@ -197,6 +200,7 @@ module Meta = struct
 		| NotNull -> ":notNull"
 		| NoUsing -> ":noUsing"
 		| Ns -> ":ns"
+		| Op -> ":op"
 		| Optional -> ":optional"
 		| Overload -> ":overload"
 		| Public -> ":public"
@@ -245,7 +249,7 @@ module Meta = struct
 		h
 
 	let parse s = try Hashtbl.find hmeta (":" ^ s) with Not_found -> Custom (":" ^ s)
-		
+
 	let from_string s =
 		if s = "" then Custom "" else match s.[0] with
 		| ':' -> (try Hashtbl.find hmeta s with Not_found -> Custom s)

tests/unit/MyAbstract.hx

@@ -106,4 +106,50 @@ abstract AbstractZ(AbstractBase<T>)<T> from AbstractBase<T> {
 	@:to public static function toString(a:AbstractBase<String>):String {
 		return a.value;
 	}
+}
+
+class MyPoint3 {
+	public var x:Float;
+	public var y:Float;
+	public var z:Float;
+	public function new(x, y, z) {
+		this.x = x;
+		this.y = y;
+		this.z = z;
+	}
+}
+
+abstract MyVector(MyPoint3) from MyPoint3 to MyPoint3 {
+	@:op(A + B) static public inline function add(lhs:MyVector, rhs:MyVector):MyVector {
+		return new MyPoint3(lhs.x + rhs.x, lhs.y + rhs.y, lhs.z + rhs.z);
+	}
+	
+	@:op(A *= B) static public inline function scalarAssign(lhs:MyVector, rhs:Float):MyVector {
+		lhs.x *= rhs;
+		lhs.y *= rhs;
+		lhs.z *= rhs;
+		return lhs;
+	}
+	
+	@:op(A * B) static public inline function scalar(lhs:MyVector, rhs:Float):MyVector {
+		return new MyPoint3(lhs.x * rhs, lhs.y * rhs, lhs.z * rhs);
+	}
+					
+	public inline function get():MyPoint3
+		return this
+		
+	@:to public inline function toString():String
+		return untyped '(${this.x},${this.y},${this.z})'
+}
+
+abstract MyInt(Int) from Int to Int {
+	// MyInt + MyInt can be used as is, and returns a MyInt
+	@:op(A + B) static public function add(lhs:MyInt, rhs:MyInt):MyInt;
+	
+	@:commutative @:op(A * B) static public function repeat(lhs:MyInt, rhs:String):String {
+		var s:StringBuf = new StringBuf();
+		for (i in 0...lhs)
+			s.add(rhs);
+		return s.toString();
+	}
 }

tests/unit/TestBasetypes.hx

@@ -374,4 +374,26 @@ class TestBasetypes extends Test {
 		eq("Distance: 12.5km", "Distance: " + km);
 		eq("Distance: 12.5m", "Distance: " + m);
 	}
+	
+	function testAbstractOperatorOverload() {
+		var v1:unit.MyAbstract.MyVector = new unit.MyAbstract.MyPoint3(1, 1, 1);
+		var v2:unit.MyAbstract.MyVector = new unit.MyAbstract.MyPoint3(1, 2, 3);
+		eq("(2,3,4)", v1 + v2);
+		eq("(2,4,6)", v2 * 2.);
+		var v1Old = v1;
+		v1 *= 2.;
+		eq("(2,2,2)", v1);
+		eq(v1Old, v1);
+		var v3 = v1 * 2.;
+		eq("(4,4,4)", v3);
+		f(v1 == v3);
+		
+		var i:unit.MyAbstract.MyInt = 1;
+		eq(2, i + i);
+		i = i + i;
+		eq(2, i);
+		var r:unit.MyAbstract.MyInt = 5;
+		eq("aaaaa", r * "a");
+		eq("aaaaa", "a" * r);
+	}
 }

type.ml

@@ -244,7 +244,7 @@ and tabstract = {
 	a_doc : Ast.documentation;
 	mutable a_meta : metadata;
 	mutable a_types : type_params;
-
+	mutable a_ops : (Ast.binop * tclass_field) list;
 	mutable a_impl : tclass option;
 	mutable a_this : t;
 	mutable a_from : (t * tclass_field option) list;

typeload.ml

@@ -105,6 +105,7 @@ let make_module ctx mpath file tdecls loadp =
 				a_meta = d.d_meta;
 				a_from = [];
 				a_to = [];
+				a_ops = [];
 				a_impl = None;
 				a_this = mk_mono();
 			} in
@@ -1362,6 +1363,12 @@ let init_class ctx c p context_init herits fields =
 						a.a_to <- (follow m, Some cf) :: a.a_to
 					end else if f.cff_name = "_new" && Meta.has Meta.Generic a.a_meta then
 						do_bind := false
+					else (try match Meta.get Meta.Op cf.cf_meta with
+						| _,[EBinop(op,_,_),_],_ ->
+							a.a_ops <- (op,cf) :: a.a_ops;
+							if fd.f_expr = None then do_bind := false;
+						| _ -> ()
+						with Not_found -> ())
 				| _ ->
 					());
 			init_meta_overloads ctx cf;
@@ -1512,7 +1519,8 @@ let init_class ctx c p context_init herits fields =
 	(match c.cl_kind with
 	| KAbstractImpl a ->
 		a.a_to <- List.rev a.a_to;
-		a.a_from <- List.rev a.a_from
+		a.a_from <- List.rev a.a_from;
+		a.a_ops <- List.rev a.a_ops;
 	| _ -> ());
 	c.cl_ordered_statics <- List.rev c.cl_ordered_statics;
 	c.cl_ordered_fields <- List.rev c.cl_ordered_fields;

typer.ml

@@ -1220,7 +1220,7 @@ let type_generic_function ctx (e,cf) el p =
 	with Codegen.Generic_Exception (msg,p) ->
 		error msg p)
 
-let rec type_binop ctx op e1 e2 p =
+let rec type_binop ctx op e1 e2 is_assign_op p =
 	match op with
 	| OpAssign ->
 		let e1 = type_access ctx (fst e1) (snd e1) MSet in
@@ -1246,19 +1246,24 @@ let rec type_binop ctx op e1 e2 p =
 		(match type_access ctx (fst e1) (snd e1) MSet with
 		| AKNo s -> error ("Cannot access field or identifier " ^ s ^ " for writing") p
 		| AKExpr e | AKField (e,_,_) ->
-			let eop = type_binop ctx op e1 e2 p in
+			let eop = type_binop ctx op e1 e2 true p in
 			(match eop.eexpr with
 			| TBinop (_,_,e2) ->
 				unify ctx eop.etype e.etype p;
 				check_assign ctx e;
 				mk (TBinop (OpAssignOp op,e,e2)) e.etype p;
+			| TField(e2,FDynamic ":needsAssign") ->
+				unify ctx e2.etype e.etype p;
+				check_assign ctx e;
+				mk (TBinop (OpAssign,e,e2)) e.etype p;
 			| _ ->
-				assert false)
+				(* this must be an abstract cast *)
+				eop)
 		| AKSet (e,m,t,f) ->
 			let l = save_locals ctx in
 			let v = gen_local ctx e.etype in
 			let ev = mk (TLocal v) e.etype p in
-			let get = type_binop ctx op (EField ((EConst (Ident v.v_name),p),f),p) e2 p in
+			let get = type_binop ctx op (EField ((EConst (Ident v.v_name),p),f),p) e2 true p in
 			unify ctx get.etype t p;
 			l();
 			mk (TBlock [
@@ -1287,6 +1292,44 @@ let rec type_binop ctx op e1 e2 p =
 			make_call ctx acc [e] ctx.t.tstring e.epos
 		| KInt | KFloat | KString -> e
 	in
+	let find_overload a t left =
+		let rec loop ops = match ops with
+			| [] -> raise Not_found
+			| (o,cf) :: ops when is_assign_op && o = OpAssignOp(op) || o == op ->
+				(match follow cf.cf_type with
+				| TFun([(_,_,t1);(_,_,t2)],r) when (left || Meta.has Meta.Commutative cf.cf_meta) && type_iseq t t2 ->
+					cf,r,o = OpAssignOp(op)
+				| _ -> loop ops)
+			| _ :: ops ->
+				loop ops
+		in
+		loop a.a_ops
+	in
+	let mk_cast_op c f a pl e1 e2 r assign =
+		match f.cf_expr with
+		| None -> mk (TBinop (op,e1,e2)) r p
+		| Some _ ->
+			let t = field_type ctx c [] f p in
+			let t = apply_params a.a_types pl t in
+			let et = type_module_type ctx (TClassDecl c) None p in
+			let ef = mk (TField (et,FStatic (c,f))) t p in
+			let ec = make_call ctx ef [e1;e2] r p in
+			(* obviously a hack to report back that we need an assignment *)
+			if is_assign_op && not assign then mk (TField(ec,FDynamic ":needsAssign")) t_dynamic p else ec
+	in
+	try (match e1.etype with
+		| TAbstract ({a_impl = Some c} as a,pl) ->
+			let f,r,assign = find_overload a e2.etype true in
+			mk_cast_op c f a pl e1 e2 r assign
+		| _ ->
+			raise Not_found)
+	with Not_found -> try (match e2.etype with
+		| TAbstract ({a_impl = Some c} as a,pl) ->
+			let f,r,assign = find_overload a e1.etype false in
+			mk_cast_op c f a pl e2 e1 r assign
+		| _ ->
+			raise Not_found)
+	with Not_found ->
 	let mk_op t =
 		if op = OpAdd && (classify t) = KString then
 			let e1 = to_string e1 in
@@ -1482,7 +1525,7 @@ and type_unop ctx op flag e p =
 		let eget = (EField ((EConst (Ident v.v_name),p),f),p) in
 		match flag with
 		| Prefix ->
-			let get = type_binop ctx op eget one p in
+			let get = type_binop ctx op eget one false p in
 			unify ctx get.etype t p;
 			l();
 			mk (TBlock [
@@ -1493,7 +1536,7 @@ and type_unop ctx op flag e p =
 			let v2 = gen_local ctx t in
 			let ev2 = mk (TLocal v2) t p in
 			let get = type_expr ctx eget Value in
-			let plusone = type_binop ctx op (EConst (Ident v2.v_name),p) one p in
+			let plusone = type_binop ctx op (EConst (Ident v2.v_name),p) one false p in
 			unify ctx get.etype t p;
 			l();
 			mk (TBlock [
@@ -2029,7 +2072,7 @@ and type_expr ctx (e,p) (with_type:with_type) =
 	| EConst c ->
 		Codegen.type_constant ctx.com c p
     | EBinop (op,e1,e2) ->
-		type_binop ctx op e1 e2 p
+		type_binop ctx op e1 e2 false p
 	| EBlock [] when with_type <> NoValue ->
 		type_expr ctx (EObjectDecl [],p) with_type
 	| EBlock l ->