abstract cleanup (fixed issue #1593)

typeload.ml

@@ -1476,16 +1476,17 @@ let init_class ctx c p context_init herits fields =
 			(match c.cl_kind with
 				| KAbstractImpl a ->
 					let m = mk_mono() in
+					let ta = TAbstract(a, List.map (fun _ -> mk_mono()) a.a_types) in
+					let tthis = if Meta.has Meta.Impl f.cff_meta || Meta.has Meta.To f.cff_meta then monomorphs a.a_types a.a_this else a.a_this in
 					if Meta.has Meta.From f.cff_meta then begin
-						let ta = TAbstract(a, List.map (fun _ -> mk_mono()) a.a_types) in
-						if not (type_iseq ret ta) then raise (Error (Unify [Cannot_unify (ret,ta)],p));
+						(* the return type of a from-function must be the abstract, not the underlying type *)
 						(try unify_raise ctx t (tfun [m] ta) f.cff_pos with Error (Unify l,p) -> error (error_msg (Unify l)) p);
 						a.a_from <- (follow m, Some cf) :: a.a_from
 					end else if Meta.has Meta.To f.cff_meta then begin
-						let ta = monomorphs a.a_types (monomorphs params a.a_this) in
-						(try unify_raise ctx t (tfun [ta] m) f.cff_pos with Error (Unify l,p) -> error (error_msg (Unify l)) p);
+						(* the first argument of a to-function must be the underlying type, not the abstract *)
+						(try unify_raise ctx t (tfun [tthis] m) f.cff_pos with Error (Unify l,p) -> error (error_msg (Unify l)) p);
 						(* multitype @:to functions must unify with a_this *)
-						if Meta.has Meta.MultiType a.a_meta then delay ctx PFinal (fun () -> unify ctx m (monomorphs a.a_types a.a_this) f.cff_pos);
+						if Meta.has Meta.MultiType a.a_meta then delay ctx PFinal (fun () -> unify ctx m tthis f.cff_pos);
 						if not (Meta.has Meta.Impl cf.cf_meta) then cf.cf_meta <- (Meta.Impl,[],cf.cf_pos) :: cf.cf_meta;
 						a.a_to <- (follow m, Some cf) :: a.a_to
 					end else if Meta.has Meta.ArrayAccess f.cff_meta then begin
@@ -1494,9 +1495,13 @@ let init_class ctx c p context_init herits fields =
 						do_bind := false
 					else (try match Meta.get Meta.Op cf.cf_meta with
 						| _,[EBinop(op,_,_),_],_ ->
+							let targ = if Meta.has Meta.Impl f.cff_meta then tthis else ta in
+							(try type_eq EqStrict t (tfun [targ;m] (mk_mono())) with Unify_error l -> raise (Error ((Unify l),f.cff_pos)));
 							a.a_ops <- (op,cf) :: a.a_ops;
 							if fd.f_expr = None then do_bind := false;
 						| _,[EUnop(op,flag,_),_],_ ->
+							let targ = if Meta.has Meta.Impl f.cff_meta then tthis else ta in
+							(try type_eq EqStrict t (tfun [targ] (mk_mono())) with Unify_error l -> raise (Error ((Unify l),f.cff_pos)));
 							a.a_unops <- (op,flag,cf) :: a.a_unops;
 							if fd.f_expr = None then do_bind := false;
 						| _ -> ()
@@ -1677,6 +1682,7 @@ let init_class ctx c p context_init herits fields =
 		a.a_to <- List.rev a.a_to;
 		a.a_from <- List.rev a.a_from;
 		a.a_ops <- List.rev a.a_ops;
+		a.a_unops <- List.rev a.a_unops;
 	| _ -> ());
 	c.cl_ordered_statics <- List.rev c.cl_ordered_statics;
 	c.cl_ordered_fields <- List.rev c.cl_ordered_fields;

typer.ml

@@ -1570,14 +1570,17 @@ let rec type_binop ctx op e1 e2 is_assign_op p =
 	| OpAssignOp _ ->
 		assert false
 	in
-	let find_overload a c t left =
+	let find_overload a pl c 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 (monomorphs cf.cf_params cf.cf_type) with
-				| TFun([(_,_,t1);(_,_,t2)],r) when (left || Meta.has Meta.Commutative cf.cf_meta) && type_iseq t t2 ->
-					if not (can_access ctx c cf true) then display_error ctx ("Cannot access operator function " ^ (s_type_path a.a_path) ^ "." ^ cf.cf_name) p;
-					cf,r,o = OpAssignOp(op)
+				| TFun([(_,_,t1);(_,_,t2)],r) when
+					(left || Meta.has Meta.Commutative cf.cf_meta)
+					&& type_iseq t t2
+					&& if Meta.has Meta.Impl cf.cf_meta then type_iseq (apply_params a.a_types pl a.a_this) t1 else type_iseq (TAbstract(a,pl)) t1 ->
+						if not (can_access ctx c cf true) then display_error ctx ("Cannot access operator function " ^ (s_type_path a.a_path) ^ "." ^ cf.cf_name) p;
+						cf,r,o = OpAssignOp(op)
 				| _ -> loop ops)
 			| _ :: ops ->
 				loop ops
@@ -1604,7 +1607,7 @@ let rec type_binop ctx op e1 e2 is_assign_op p =
 	in
 	try (match follow e1.etype with
 		| TAbstract ({a_impl = Some c} as a,pl) ->
-			let f,r,assign = find_overload a c e2.etype true in
+			let f,r,assign = find_overload a pl c e2.etype true in
 			begin match f.cf_expr with
 				| None ->
 					let e2 = match follow e2.etype with TAbstract(a,pl) -> {e2 with etype = apply_params a.a_types pl a.a_this} | _ -> e2 in
@@ -1616,7 +1619,7 @@ let rec type_binop ctx op e1 e2 is_assign_op p =
 			raise Not_found)
 	with Not_found -> try (match follow e2.etype with
 		| TAbstract ({a_impl = Some c} as a,pl) ->
-			let f,r,assign = find_overload a c e1.etype false in
+			let f,r,assign = find_overload a pl c e1.etype false in
 			begin match f.cf_expr with
 				| None ->
 					let e1 = match follow e1.etype with TAbstract(a,pl) -> {e1 with etype = apply_params a.a_types pl a.a_this} | _ -> e1 in
@@ -1656,11 +1659,19 @@ and type_unop ctx op flag e p =
 		in
 		try (match follow e.etype with
 			| TAbstract ({a_impl = Some c} as a,pl) ->
-				let _,_,cf = List.find (fun (op2,flag2,cf) -> op2 == op && flag2 == flag) a.a_unops in
+				let rec loop opl = match opl with
+					| [] -> raise Not_found
+					| (op2,flag2,cf) :: opl when op == op2 && flag == flag2 ->
+						let m = mk_mono() in
+						let tcf = apply_params c.cl_types pl (monomorphs cf.cf_params cf.cf_type) in
+						if Meta.has Meta.Impl cf.cf_meta then begin
+							if type_iseq (tfun [apply_params a.a_types pl a.a_this] m) tcf then cf,tcf,m else loop opl
+						end else
+							if type_iseq (tfun [e.etype] m) tcf then cf,tcf,m else loop opl
+					| _ :: opl -> loop opl
+				in
+				let cf,t,r = loop a.a_unops in
 				if not (can_access ctx c cf true) then error ("Cannot access " ^ cf.cf_name) p;
-				let t = field_type ctx c [] cf p in
-				let t = apply_params a.a_types pl t in
-				let r = match t with TFun (_,r) -> r | _ -> error "Invalid operation" p in
 				(match cf.cf_expr with
 				| None ->
 					let e = make {e with etype = apply_params a.a_types pl a.a_this} in