initial support for abstract casts using @:from and @:to functions

Makefile

@@ -62,7 +62,7 @@ export:
 	cp haxe*.exe doc/CHANGES.txt $(EXPORT)
 	rsync -a --exclude .svn --exclude *.n --exclude std/libs --delete std $(EXPORT)
 
-codegen.cmx: typeload.cmx typecore.cmx type.cmx genxml.cmx common.cmx ast.cmx
+codegen.cmx: optimizer.cmx typeload.cmx typecore.cmx type.cmx genxml.cmx common.cmx ast.cmx
 
 common.cmx: type.cmx ast.cmx
 

codegen.ml

@@ -1297,6 +1297,125 @@ let check_local_vars_init e =
 	loop (ref PMap.empty) e;
 	e
 
+(* -------------------------------------------------------------------------- *)
+(* ABSTRACT CASTS *)
+
+let handle_abstract_casts ctx e =
+	let make_cast_call c cf earg t p =
+		let ta = TAnon { a_fields = c.cl_statics; a_status = ref (Statics c) } in
+		let ethis = mk (TTypeExpr (TClassDecl c)) ta p in
+		(match cf.cf_expr with
+		| Some { eexpr = TFunction fd } ->
+			(match Optimizer.type_inline ctx cf fd ethis earg t p false with
+				| Some e -> e
+				| None ->
+					let e = mk (TField (ethis,(FStatic (c,cf)))) cf.cf_type p in
+					mk (TCall(e,earg)) t p)
+		| _ ->
+			assert false)
+	in
+	let find_from_cast c a t p =
+		let rec loop cfl = match cfl with
+			| [] ->
+				error (Printf.sprintf "Cannot cast %s to %s" (s_type_path a.a_path) (s_type (print_context()) t)) p;
+			| cf :: cfl when has_meta ":from" cf.cf_meta ->
+				begin match follow cf.cf_type with
+				| TFun([_,_,ta],_) when type_iseq ta t ->
+					cf
+				| _ ->
+					loop cfl
+				end
+			| _ :: cfl ->
+				loop cfl
+		in
+		loop c.cl_ordered_statics
+	in
+	let find_to_cast c a t p =
+		let rec loop cfl = match cfl with
+			| [] ->
+				error (Printf.sprintf "Cannot cast %s to %s" (s_type (print_context()) t) (s_type_path a.a_path)) p;
+			| cf :: cfl when has_meta ":to" cf.cf_meta ->
+				begin match follow cf.cf_type with
+				| TFun([ta],r) when type_iseq r t ->
+					cf
+				| _ ->
+					loop cfl
+				end
+			| _ :: cfl ->
+				loop cfl
+		in
+		loop c.cl_ordered_statics
+	in
+	let rec check_cast tleft eright p =
+		let eright = loop eright in
+		match follow tleft,follow eright.etype with
+		| TAbstract({a_impl = Some _} as a1,_),TAbstract({a_impl = Some _} as a2,_) ->
+			if a1 != a2 then
+				error "not implemented yet" p
+			else
+				eright
+		| TDynamic _,_ | _,TDynamic _ ->
+			eright
+		| TAbstract({a_impl = Some c} as a ,_),t ->
+			let cf = find_from_cast c a eright.etype p in
+			make_cast_call c cf [eright] tleft p
+		| t,TAbstract({a_impl = Some c} as a,_) ->
+			let cf = find_to_cast c a t p in
+			make_cast_call c cf [eright] tleft p
+		| _ ->
+			eright
+	and loop e = match e.eexpr with
+		| TBinop(OpAssign,e1,e2) ->
+			let e2 = check_cast e1.etype e2 e.epos in
+			{ e with eexpr = TBinop(OpAssign,loop e1,e2) }
+		| TVars vl ->
+			let vl = List.map (fun (v,eo) -> match eo with
+				| None -> (v,eo)
+				| Some e -> (v,Some (check_cast v.v_type e e.epos))
+			) vl in
+			{ e with eexpr = TVars vl }
+		| TCall(e1, el) ->
+			begin match follow e1.etype with
+				| TFun(args,_) ->
+					let rec loop2 el tl = match el,tl with
+						| [],_ -> []
+						| e :: el, [] -> (loop e) :: loop2 el []
+						| e :: el, (_,_,t) :: tl ->
+							(check_cast t e e.epos) :: loop2 el tl
+					in
+					let el = loop2 el args in
+					{ e with eexpr = TCall(loop e1,el)}
+				| _ ->
+					e
+			end
+		| TArrayDecl el ->
+			begin match e.etype with
+				| TInst(_,[t]) ->
+					let el = List.map (fun e -> check_cast t e e.epos) el in
+					{ e with eexpr = TArrayDecl el}
+				| _ ->
+					e
+			end
+		| TObjectDecl fl ->
+			begin match follow e.etype with
+			| TAnon a ->
+				let fl = List.map (fun (n,e) ->
+					try
+						let cf = PMap.find n a.a_fields in
+						let e = match e.eexpr with TCast(e1,None) -> e1 | _ -> e in
+						(n,check_cast cf.cf_type e e.epos)
+					with Not_found ->
+						(n,loop e)
+				) fl in
+				{ e with eexpr = TObjectDecl fl }
+			| _ ->
+				e
+			end
+		| _ ->
+			Type.map_expr loop e
+	in
+	loop e
+
 (* -------------------------------------------------------------------------- *)
 (* POST PROCESS *)
 

main.ml

@@ -1102,6 +1102,7 @@ try
 		com.types <- types;
 		com.modules <- modules;
 		let filters = [
+			Codegen.handle_abstract_casts tctx;
 			if com.foptimize then Optimizer.reduce_expression tctx else Optimizer.sanitize tctx;
 			Codegen.check_local_vars_init;
 			Codegen.captured_vars com;

tests/unit/MyAbstract.hx

@@ -16,3 +16,19 @@ abstract MyAbstract(Int) {
 
 }
 
+abstract TemplateWrap(haxe.Template) {
+	public inline function new(x) {
+		this = new haxe.Template(x);
+	}
+	
+	public inline function get()
+		return this
+	
+	@:from static inline public function fromString(s:String) {
+		return new TemplateWrap(s);
+	}
+	
+	@:to inline function toString() {
+		return this.execute( { t: "really works!"});
+	}
+}

tests/unit/TestBasetypes.hx

@@ -283,4 +283,69 @@ class TestBasetypes extends Test {
 		eq( b.toInt(), 33 );
 	}
 
+	function testAbstractCast() {
+		var s = "Abstract casting ::t::";
+		// var from
+		var tpl:unit.MyAbstract.TemplateWrap = s;
+		t(Std.is(tpl, haxe.Template));
+		t(Std.is(tpl.get(), haxe.Template));
+		eq(tpl.get().execute( { t:"works!" } ), "Abstract casting works!");
+		
+		//var to
+		var str:String = tpl;
+		t(Std.is(str, String));
+		eq(str, "Abstract casting really works!");
+		
+		// assign from
+		var tpl:unit.MyAbstract.TemplateWrap;
+		tpl = s;
+		t(Std.is(tpl, haxe.Template));
+		t(Std.is(tpl.get(), haxe.Template));
+		eq(tpl.get().execute( { t:"works!" } ), "Abstract casting works!");
+		
+		//assign to
+		var str:String;
+		str = tpl;
+		t(Std.is(str, String));
+		eq(str, "Abstract casting really works!");
+		
+		// call arg from
+		function from(tpl:unit.MyAbstract.TemplateWrap) {
+			eq(tpl.get().execute( { t:"works!" } ), "Abstract casting works!");
+		}
+		from(s);
+		
+		// call arg to
+		function from(s:String) {
+			eq(s, "Abstract casting really works!");
+		}
+		from(tpl);
+		
+		// object decl from variant
+		var obj: { tpl:unit.MyAbstract.TemplateWrap } = { tpl:s };
+		eq(obj.tpl.get().execute( { t:"works!" } ), "Abstract casting works!");
+		
+		// object decl from
+		var obj: { tpl:unit.MyAbstract.TemplateWrap };
+		obj = { tpl:s };
+		eq(obj.tpl.get().execute( { t:"works!" } ), "Abstract casting works!");
+		
+		// object decl to variant
+		var obj: { s:String } = { s:tpl };
+		eq(obj.s, "Abstract casting really works!");
+		
+		// object decl to
+		var obj: { s:String };
+		obj = { s:tpl };
+		eq(obj.s, "Abstract casting really works!");
+		
+		// array from
+		var arr:Array<unit.MyAbstract.TemplateWrap> = [s, "foo"];
+		eq(arr[0].get().execute( { t:"works!" } ), "Abstract casting works!");
+		eq(arr[1].get().execute( { } ), "foo");
+		
+		// array to
+		var arr:Array<String> = [tpl];
+		eq(arr[0], "Abstract casting really works!");
+	}
 }

tests/unit/unitstd/Array.unit.hx

@@ -231,10 +231,12 @@ var func = function(s) return s.toUpperCase();
 [].filter(function(i) return true) == [];
 [].filter(function(i) return false) == [];
 
+#if !as3
 // check that map and filter work well on Dynamic as well
 var a : Dynamic = [0,1,2];
 var b : Dynamic = a.filter(function(x) return x & 1 == 0).map(function(x) return x * 10);
 b.length == 2;
 b[0] = 0;
 b[1] = 20;
+#end
 #end

typeload.ml

@@ -141,6 +141,7 @@ let make_module ctx mpath file tdecls loadp =
 						} in
 						{ f with cff_name = "_new"; cff_access = AStatic :: f.cff_access; cff_kind = FFun fu }
 					| FFun fu when not stat ->
+						if has_meta ":from" f.cff_meta then error "@:from cast functions must be static" f.cff_pos;
 						let fu = { fu with f_args = ("this",false,Some this_t,None) :: fu.f_args } in
 						{ f with cff_kind = FFun fu; cff_access = AStatic :: f.cff_access }
 					| _ ->
@@ -1308,6 +1309,19 @@ let init_class ctx c p context_init herits fields =
 				name, c, t
 			) fd.f_args in
 			let t = TFun (fun_args args,ret) in
+			(match c.cl_kind with
+				| KAbstractImpl a ->
+					let m = mk_mono() in
+					if has_meta ":from" f.cff_meta then begin
+						let t_abstract = TAbstract(a,(List.map (fun _ -> mk_mono()) a.a_types)) in
+						unify ctx t (tfun [m] t_abstract) f.cff_pos;
+						a.a_from <- (follow m) :: a.a_from
+					end else if has_meta ":to" f.cff_meta then begin
+						unify ctx t (tfun [a.a_this] m) f.cff_pos;
+						a.a_to <- (follow m) :: a.a_to
+					end
+				| _ ->
+					());
 			if constr && c.cl_interface then error "An interface cannot have a constructor" p;
 			if c.cl_interface && not stat && fd.f_expr <> None then error "An interface method cannot have a body" p;
 			if constr then (match fd.f_type with