allow @:generic on functions (fixed issue #1158)

codegen.ml

@@ -199,6 +199,65 @@ let extend_remoting ctx c t p async prot =
 (* -------------------------------------------------------------------------- *)
 (* HAXE.RTTI.GENERIC *)
 
+exception Generic_Exception of string * Ast.pos
+
+type generic_context = {
+	ctx : typer;
+	subst : (t * t) list;
+	name : string;
+	p : pos;
+}
+
+let make_generic ctx ps pt p =
+	let rec loop l1 l2 =
+		match l1, l2 with
+		| [] , [] -> []
+		| (x,TLazy f) :: l1, _ -> loop ((x,(!f)()) :: l1) l2
+		| (_,t1) :: l1 , t2 :: l2 -> (t1,t2) :: loop l1 l2
+		| _ -> assert false
+	in
+	let name =
+		String.concat "_" (List.map2 (fun (s,_) t ->
+			let path = (match follow t with		
+				| TInst (ct,_) -> ct.cl_path
+				| TEnum (e,_) -> e.e_path
+				| TMono _ -> raise (Generic_Exception (("Could not determine type for parameter " ^ s), p))
+				| t -> raise (Generic_Exception (("Type parameter must be a class or enum instance (found " ^ (s_type (print_context()) t) ^ ")"), p))
+			) in
+			match path with
+			| [] , name -> name
+			| l , name -> String.concat "_" l ^ "_" ^ name
+		) ps pt)
+	in
+	{
+		ctx = ctx;
+		subst = loop ps pt;
+		name = name;
+		p = p;
+	}
+
+let rec generic_substitute_type gctx t =
+	match t with
+	| TInst ({ cl_kind = KGeneric } as c2,tl2) ->
+		(* maybe loop, or generate cascading generics *)
+		let _, _, f = gctx.ctx.g.do_build_instance gctx.ctx (TClassDecl c2) gctx.p in
+		f (List.map (generic_substitute_type gctx) tl2)
+	| _ ->
+		try List.assq t gctx.subst with Not_found -> Type.map (generic_substitute_type gctx) t
+
+let generic_substitute_expr gctx e =
+	let vars = Hashtbl.create 0 in
+	let build_var v =
+		try
+			Hashtbl.find vars v.v_id
+		with Not_found ->
+			let v2 = alloc_var v.v_name (generic_substitute_type gctx v.v_type) in
+			Hashtbl.add vars v.v_id v2;
+			v2
+	in
+	let rec build_expr e = map_expr_type build_expr (generic_substitute_type gctx) build_var e in
+	build_expr e
+
 let rec build_generic ctx c p tl =
 	let pack = fst c.cl_path in
 	let recurse = ref false in
@@ -210,18 +269,9 @@ let rec build_generic ctx c p tl =
 		| _ ->
 			()
 	in
-	let name = String.concat "_" (snd c.cl_path :: (List.map (fun t ->
-		check_recursive t;
-		let path = (match follow t with
-			| TInst (c,_) -> c.cl_path
-			| TEnum (e,_) -> e.e_path
-			| TMono _ -> error "Type parameter must be explicit when creating a generic instance" p
-			| _ -> error "Type parameter must be a class or enum instance" p
-		) in
-		match path with
-		| [] , name -> name
-		| l , name -> String.concat "_" l ^ "_" ^ name
-	) tl)) in
+	List.iter check_recursive tl;
+	let gctx = make_generic ctx c.cl_types tl p in
+	let name = (snd c.cl_path) ^ "_" ^ gctx.name in
 	if !recurse then begin
 		if not (has_meta ":?genericRec" c.cl_meta) then c.cl_meta <- (":?genericRec",[],p) :: c.cl_meta;
 		TInst (c,tl) (* build a normal instance *)
@@ -269,36 +319,9 @@ let rec build_generic ctx c p tl =
 			List.iter loop tl
 		in
 		List.iter loop tl;
-		let rec loop l1 l2 =
-			match l1, l2 with
-			| [] , [] -> []
-			| (x,TLazy f) :: l1, _ -> loop ((x,(!f)()) :: l1) l2
-			| (_,t1) :: l1 , t2 :: l2 -> (t1,t2) :: loop l1 l2
-			| _ -> assert false
-		in
-		let subst = loop c.cl_types tl in
-		let rec build_type t =
-			match t with
-			| TInst ({ cl_kind = KGeneric } as c2,tl2) ->
-				(* maybe loop, or generate cascading generics *)
-				let _, _, f = ctx.g.do_build_instance ctx (TClassDecl c2) p in
-				f (List.map build_type tl2)
-			| _ ->
-				try List.assq t subst with Not_found -> Type.map build_type t
-		in
-		let vars = Hashtbl.create 0 in
-		let build_var v =
-			try
-				Hashtbl.find vars v.v_id
-			with Not_found ->
-				let v2 = alloc_var v.v_name (build_type v.v_type) in
-				Hashtbl.add vars v.v_id v2;
-				v2
-		in
-		let rec build_expr e = map_expr_type build_expr build_type build_var e in
 		let build_field f =
-			let t = build_type f.cf_type in
-			{ f with cf_type = t; cf_expr = (match f.cf_expr with None -> None | Some e -> Some (build_expr e)) }
+			let t = generic_substitute_type gctx f.cf_type in
+			{ f with cf_type = t; cf_expr = (match f.cf_expr with None -> None | Some e -> Some (generic_substitute_expr gctx e)) }
 		in
 		if c.cl_init <> None || c.cl_dynamic <> None then error "This class can't be generic" p;
 		if c.cl_ordered_statics <> [] then error "A generic class can't have static fields" p;
@@ -321,7 +344,7 @@ let rec build_generic ctx c p tl =
 			| _ -> error "Please define a constructor for this class in order to use it as generic" c.cl_pos
 		);
 		cg.cl_implements <- List.map (fun (i,tl) ->
-			(match follow (build_type (TInst (i, List.map build_type tl))) with
+			(match follow (generic_substitute_type gctx (TInst (i, List.map (generic_substitute_type gctx) tl))) with
 			| TInst (i,tl) -> i, tl
 			| _ -> assert false)
 		) c.cl_implements;
@@ -606,7 +629,7 @@ let add_rtti ctx t =
 let remove_extern_fields ctx t = match t with
 	| TClassDecl c ->
 		let do_remove f =
-			(not ctx.in_macro && f.cf_kind = Method MethMacro) || has_meta ":extern" f.cf_meta
+			(not ctx.in_macro && f.cf_kind = Method MethMacro) || has_meta ":extern" f.cf_meta || has_meta ":generic" f.cf_meta
 		in
 		if not (Common.defined ctx.com "doc_gen") then begin
 			c.cl_ordered_fields <- List.filter (fun f ->

tests/unit/Test.hx

@@ -51,6 +51,30 @@ package unit;
 				return;
 		report(v+" not in "+Std.string(values),pos);
 	}
+	
+	function hf(c:Class<Dynamic>, n:String, ?pos:haxe.PosInfos) {
+		Test.count++;
+		if (!Lambda.has(Type.getInstanceFields(c), n))
+			Test.report(Type.getClassName(c) + " should have member field " +n, pos);
+	}
+	
+	function nhf(c:Class<Dynamic>, n:String, ?pos:haxe.PosInfos) {
+		Test.count++;
+		if (Lambda.has(Type.getInstanceFields(c), n))
+			Test.report(Type.getClassName(c) + " should not have member field " +n, pos);
+	}
+	
+	function hsf(c:Class<Dynamic> , n:String, ?pos:haxe.PosInfos) {
+		Test.count++;
+		if (!Lambda.has(Type.getClassFields(c), n))
+			Test.report(Type.getClassName(c) + " should have static field " +n, pos);
+	}	
+	
+	function nhsf(c:Class<Dynamic> , n:String, ?pos:haxe.PosInfos) {
+		Test.count++;
+		if (Lambda.has(Type.getClassFields(c), n))
+			Test.report(Type.getClassName(c) + " should not have static field " +n, pos);
+	}	
 
 	function infos( m : String ) {
 		reportInfos = m;

tests/unit/TestDCE.hx

@@ -131,30 +131,6 @@ class TestDCE extends Test {
 		t(Type.resolveClass("unit.UsedConstructedChild") == null);
 		t(Type.resolveClass("unit.UsedReferencedChild") == null);	
 	}
-	
-	function hf(c:Class<Dynamic>, n:String, ?pos:haxe.PosInfos) {
-		Test.count++;
-		if (!Lambda.has(Type.getInstanceFields(c), n))
-			Test.report(Type.getClassName(c) + " should have member field " +n, pos);
-	}
-	
-	function nhf(c:Class<Dynamic>, n:String, ?pos:haxe.PosInfos) {
-		Test.count++;
-		if (Lambda.has(Type.getInstanceFields(c), n))
-			Test.report(Type.getClassName(c) + " should not have member field " +n, pos);
-	}
-	
-	function hsf(c:Class<Dynamic> , n:String, ?pos:haxe.PosInfos) {
-		Test.count++;
-		if (!Lambda.has(Type.getClassFields(c), n))
-			Test.report(Type.getClassName(c) + " should have static field " +n, pos);
-	}	
-	
-	function nhsf(c:Class<Dynamic> , n:String, ?pos:haxe.PosInfos) {
-		Test.count++;
-		if (Lambda.has(Type.getClassFields(c), n))
-			Test.report(Type.getClassName(c) + " should not have static field " +n, pos);
-	}
 }
 
 class UsedConstructed {

tests/unit/TestType.hx

@@ -521,5 +521,49 @@ class TestType extends Test {
 		eq(r[1], 2);	
 		eq(r[2][0], 3);
 		#end
+	}
+	
+	public function testGenericFunction() {
+		gf1(2);
+		gf1("foo");
+		gf1(true);
+		gf1(new haxe.Template("foo"));
+		gf1(new haxe.FastList<Int>());
+		hsf(TestType, "gf1_Int");
+		hsf(TestType, "gf1_String");
+		hsf(TestType, "gf1_Bool");
+		hsf(TestType, "gf1_haxe_Template");
+		hsf(TestType, #if (flash9 || cpp) "gf1_haxe_FastList_Int" #else "gf1_haxe_FastList" #end);
+		t(typeError(gf1(null))); // monos don't work
+		t(typeError(gf1( { foo:1 } ))); // structures don't work
+		
+		eq("foo[1,2]", gf2("foo", [1, 2]));
+		eq("foo[[1,2]]", gf2("foo", [[1, 2]]));
+		hsf(TestType, "gf2_String_Int");
+		hsf(TestType, "gf2_String_Array");
+		
+		var a = gf3("foo", ["bar", "baz"]);
+		eq(a[0], "bar");
+		eq(a[1], "baz");
+		eq(a[2], "foo");
+		hsf(TestType, "gf3_String_Array");
+		var t = new haxe.Template("foo");
+		var ta = gf3(t, [])[0];
+		f(t == ta);
+		hsf(TestType, "gf3_haxe_Template_Array");
+	}
+	
+	@:generic static function gf1<T>(a:T) {
+		return a;
+	}
+	
+	@:generic static function gf2<A,B>(a:A, b:Array<B>) {
+		return Std.string(a) + Std.string(b);
+	}
+	
+	@:generic static function gf3 < A, B:Array<A> > (a:A, b:B) {
+		var clone = new A("foo");
+		b.push(clone);
+		return b;
 	}	
 }

typer.ml

@@ -104,36 +104,33 @@ let rec is_pos_infos = function
 	| _ ->
 		false
 
+let add_constraint_checks ctx c pl f tl p =
+	List.iter2 (fun m (name,t) -> 
+		match follow t with
+		| TInst ({ cl_kind = KTypeParameter constr },_) when constr <> [] ->
+			let constr = List.map (fun t -> 
+				let t = apply_params f.cf_params tl t in
+				(* only apply params if not static : in that case no param is passed *)
+				let t = (if pl = [] then t else apply_params c.cl_types pl t) in
+				t
+			) constr in
+			delay_late ctx (fun() ->
+				List.iter (fun ct ->
+					try
+						Type.unify m ct
+					with Unify_error l ->
+						display_error ctx (error_msg (Unify (Constraint_failure (f.cf_name ^ "." ^ name) :: l))) p;
+				) constr
+			);
+		| _ -> ()
+	) tl f.cf_params
+
 let field_type ctx c pl f p =
 	match f.cf_params with
 	| [] -> f.cf_type
 	| l ->
 		let monos = List.map (fun _ -> mk_mono()) l in
-		List.iter2 (fun m (name,t) -> 
-			match follow t with
-			| TInst ({ cl_kind = KTypeParameter constr },_) when constr <> [] ->
-				let rec loop c pl t =
-					let t = (match c.cl_super with
-						| None -> t
-						| Some (cs,tl) -> loop cs tl t
-					) in
-					(* only apply params if not static : in that case no param is passed *)
-					if pl = [] then t else apply_params c.cl_types pl t
-				in
-				let constr = List.map (fun t -> 
-					let t = apply_params f.cf_params monos t in
-					loop c pl t
-				) constr in
-				delay_late ctx (fun() ->
-					List.iter (fun ct ->
-						try
-							Type.unify m ct
-						with Unify_error l ->
-							display_error ctx (error_msg (Unify (Constraint_failure (f.cf_name ^ "." ^ name) :: l))) p;
-					) constr
-				);
-			| _ -> ()
-		) monos l;
+		if not (has_meta ":generic" f.cf_meta) then add_constraint_checks ctx c pl f monos p;
 		apply_params l monos f.cf_type
 
 let class_field ctx c pl name p =
@@ -955,6 +952,44 @@ let unify_int ctx e k =
 		unify ctx e.etype ctx.t.tint e.epos;
 		true
 
+let type_generic_function ctx (e,cf) el p =
+	if cf.cf_params = [] then error "Function has no type parameters and cannot be generic" p;
+	let monos = List.map (fun _ -> mk_mono()) cf.cf_params in
+	let c,stat = match follow e.etype with
+		| (TInst (c,_)) -> c,false
+		| (TAnon a) -> (match !(a.a_status) with Statics c -> c,true | _ -> assert false)
+		| _ -> assert false
+	in
+	let t = apply_params cf.cf_params monos cf.cf_type in
+	add_constraint_checks ctx c [] cf monos p;
+	let args,ret = match t with
+		| TFun(args,ret) -> args,ret
+		| _ ->  error "Invalid field type for generic call" p
+	in
+	let el,tfunc = unify_call_params ctx None el args ret p false in
+	(try
+		let gctx = Codegen.make_generic ctx cf.cf_params monos p in
+		let name = cf.cf_name ^ "_" ^ gctx.Codegen.name in
+		let cf2 = mk_field name t cf.cf_pos in
+		if stat then begin
+			c.cl_statics <- PMap.add name cf2 c.cl_statics;
+			c.cl_ordered_statics <- cf2 :: c.cl_ordered_statics
+		end else begin
+			c.cl_fields <- PMap.add name cf2 c.cl_fields;
+			c.cl_ordered_fields <- cf2 :: c.cl_ordered_fields
+		end;
+		ignore(follow cf.cf_type);
+		cf2.cf_expr <- (match cf.cf_expr with
+			| None -> None
+			| Some e -> Some (Codegen.generic_substitute_expr gctx e));
+		cf2.cf_kind <- cf.cf_kind;
+		cf2.cf_public <- cf.cf_public;
+		let e = if stat then type_type ctx c.cl_path p else e in
+		let e = acc_get ctx (field_access ctx MCall cf2 cf2.cf_type e p) p in
+		(el,ret,e)
+	with Codegen.Generic_Exception (msg,p) ->
+		error msg p)
+	
 let rec type_binop ctx op e1 e2 p =
 	match op with
 	| OpAssign ->
@@ -1963,13 +1998,17 @@ and type_expr ctx ?(need_val=true) (e,p) =
 		let t = Typeload.load_instance ctx t p true in
 		let el, c , params = (match follow t with
 		| TInst ({cl_kind = KTypeParameter tl} as c,params) ->
-			if not (ctx.curclass.cl_kind = KGeneric) then display_error ctx "Type parameters can only be constructed in generic instances" p;
-			if not (has_meta ":?genericT" ctx.curclass.cl_meta) then ctx.curclass.cl_meta <- (":?genericT",[],p) :: ctx.curclass.cl_meta;
+			(* first check field parameters, then class parameters *)
+			let cf = PMap.find ctx.curmethod (match ctx.curfun with FStatic -> ctx.curclass.cl_statics | _ -> ctx.curclass.cl_fields) in
 			(try
-				let tt = List.assoc (snd c.cl_path) ctx.curclass.cl_types in
+				let tt = List.assoc (snd c.cl_path) cf.cf_params in
 				if not (type_iseq tt t) then raise Not_found;
-			with Not_found ->
-				display_error ctx "Only class type parameters can be constructed in generic instances" p);
+			with Not_found -> try
+				let tt = List.assoc (snd c.cl_path) ctx.type_params in
+				if not (type_iseq tt t) then raise Not_found;
+				if not (has_meta ":?genericT" ctx.curclass.cl_meta) then ctx.curclass.cl_meta <- (":?genericT",[],p) :: ctx.curclass.cl_meta;
+			with Not_found ->			
+				error "Only generic type parameters can be constructed" p);
 			let el = List.map (type_expr ctx) el in
 			let ctor = mk_field "new" (tfun (List.map (fun e -> e.etype) el) ctx.t.tvoid) p in
   			(match c.cl_constructor with
@@ -2336,8 +2375,12 @@ and build_call ctx acc el twith p =
 				| _ ->
 					None
 			) in
-			let el, tfunc = unify_call_params ctx fopts el args r p false in
-			el,(match tfunc with TFun(_,r) -> r | _ -> assert false), {e with etype = tfunc}
+			(match fopts,acc with
+				| Some (_,cf),AKField({eexpr = TField(e,_)},_) when has_meta ":generic" cf.cf_meta -> 
+					type_generic_function ctx (e,cf) el p
+				| _ ->
+					let el, tfunc = unify_call_params ctx fopts el args r p false in
+					el,(match tfunc with TFun(_,r) -> r | _ -> assert false), {e with etype = tfunc})
 		| TMono _ ->
 			let t = mk_mono() in
 			let el = List.map (type_expr ctx) el in