[java/cs] Added @:strict metadata that performs type checking on C#/Java

Added @:meta implementation for Java. Closes #2065

ast.ml

@@ -148,6 +148,7 @@ module Meta = struct
 		| SkipReflection
 		| Sound
 		| StoredTypedExpr
+		| Strict
 		| Struct
 		| StructAccess
 		| SuppressWarnings
@@ -761,4 +762,4 @@ let rec string_list_of_expr_path_raise (e,p) =
 	match e with
 	| EConst (Ident i) -> [i]
 	| EField (e,f) -> f :: string_list_of_expr_path_raise e
-	| _ -> raise Exit
+	| _ -> raise Exit

common.ml

@@ -475,6 +475,7 @@ module MetaInfo = struct
 		| SkipCtor -> ":skipCtor",("Used internally to generate a constructor as if it were a native type (no __hx_ctor)",[Platforms [Java;Cs]; Internal])
 		| SkipReflection -> ":skipReflection",("Used internally to annotate a field that shouldn't have its reflection data generated",[Platforms [Java;Cs]; UsedOn TClassField; Internal])
 		| Sound -> ":sound",( "Includes a given .wav or .mp3 file into the target Swf and associates it with the class (must extend flash.media.Sound)",[HasParam "File path";UsedOn TClass;Platform Flash])
+		| Strict -> ":strict",("Used to declare a native C# attribute or a native Java metadata. Is type checked",[Platforms [Java;Cs]])
 		| Struct -> ":struct",("Marks a class definition as a struct.",[Platform Cs; UsedOn TClass])
 		| StructAccess -> ":structAccess",("Marks an extern class as using struct access('.') not pointer('->').",[Platform Cpp; UsedOn TClass])
 		| SuppressWarnings -> ":suppressWarnings",("Adds a SuppressWarnings annotation for the generated Java class",[Platform Java; UsedOn TClass])

genjava.ml

@@ -1516,6 +1516,89 @@ let configure gen =
 		expr_s w e
 	in
 
+	let rec gen_fpart_attrib w = function
+		| EConst( Ident i ), _ ->
+			write w i
+		| EField( ef, f ), _ ->
+			gen_fpart_attrib w ef;
+			write w ".";
+			write w f
+		| _, p ->
+			gen.gcon.error "Invalid expression inside @:meta metadata" p
+	in
+
+	let rec gen_spart w = function
+		| EConst c, p -> (match c with
+			| Int s | Float s | Ident s ->
+				write w s
+			| String s ->
+				write w "\"";
+				write w (escape s);
+				write w "\""
+			| _ -> gen.gcon.error "Invalid expression inside @:meta metadata" p)
+		| EField( ef, f ), _ ->
+			gen_spart w ef;
+			write w ".";
+			write w f
+		| EBinop( Ast.OpAssign, (EConst (Ident s), _), e2 ), _ ->
+			write w s;
+			write w " = ";
+			gen_spart w e2
+		| EArrayDecl( el ), _ ->
+			write w "{";
+			let fst = ref true in
+			List.iter (fun e ->
+				if !fst then fst := false else write w ", ";
+				gen_spart w e
+			) el;
+			write w "}"
+		| ECall(fpart,args), _ ->
+			gen_fpart_attrib w fpart;
+			write w "(";
+			let fst = ref true in
+			List.iter (fun e ->
+				if !fst then fst := false else write w ", ";
+				gen_spart w e
+			) args;
+			write w ")"
+		| _, p ->
+			gen.gcon.error "Invalid expression inside @:meta metadata" p
+	in
+
+	let gen_annotations w ?(add_newline=true) metadata =
+		List.iter (function
+			| Meta.Meta, [meta], _ ->
+				write w "@";
+				gen_spart w meta;
+				if add_newline then newline w else write w " ";
+			| _ -> ()
+		) metadata
+	in
+
+	let argt_s p t =
+		let w = new_source_writer () in
+		let rec run t =
+			match t with
+				| TType (tdef,p) ->
+					gen_annotations w ~add_newline:false tdef.t_meta;
+					run (follow_once t)
+				| TMono r ->
+					(match !r with
+					| Some t -> run t
+					| _ -> () (* avoid infinite loop / should be the same in this context *))
+				| TLazy f ->
+					run (!f())
+				| _ -> ()
+		in
+		run t;
+		let ret = t_s p t in
+		let c = contents w in
+		if c <> "" then
+			c ^ " " ^ ret
+		else
+			ret
+	in
+
 	let get_string_params cl_params =
 		match cl_params with
 			| [] ->
@@ -1621,6 +1704,7 @@ let configure gen =
 				in
 
 				(if is_override && not is_interface then write w "@Override ");
+				gen_annotations w cf.cf_meta;
 				(* public static void funcName *)
 				let params, _ = get_string_params cf.cf_params in
 
@@ -1629,9 +1713,9 @@ let configure gen =
 				(* <T>(string arg1, object arg2) with T : object *)
 				(match cf.cf_expr with
 					| Some { eexpr = TFunction tf } ->
-							print w "(%s)" (String.concat ", " (List.map2 (fun (var,_) (_,_,t) -> sprintf "%s %s" (t_s cf.cf_pos (run_follow gen t)) (change_id var.v_name)) tf.tf_args args))
+							print w "(%s)" (String.concat ", " (List.map2 (fun (var,_) (_,_,t) -> sprintf "%s %s" (argt_s cf.cf_pos (run_follow gen t)) (change_id var.v_name)) tf.tf_args args))
 					| _ ->
-							print w "(%s)" (String.concat ", " (List.map (fun (name, _, t) -> sprintf "%s %s" (t_s cf.cf_pos (run_follow gen t)) (change_id name)) args))
+							print w "(%s)" (String.concat ", " (List.map (fun (name, _, t) -> sprintf "%s %s" (argt_s cf.cf_pos (run_follow gen t)) (change_id name)) args))
 				);
 				if is_interface || List.mem "native" modifiers then
 					write w ";"
@@ -1726,6 +1810,7 @@ let configure gen =
 		) suppress_warnings;
 		write w "})";
 		newline w;
+		gen_annotations w cl.cl_meta;
 
 		let clt, access, modifiers = get_class_modifiers cl.cl_meta (if cl.cl_interface then "interface" else "class") "public" [] in
 		let is_final = Meta.has Meta.Final cl.cl_meta in
@@ -1826,6 +1911,7 @@ let configure gen =
 				false
 		in
 
+		gen_annotations w e.e_meta;
 		print w "public enum %s" (change_clname (snd e.e_path));
 		begin_block w;
 		write w (String.concat ", " (List.map (change_id) e.e_names));

tests/unit/native_java/src/haxe/test/MyClass.java

@@ -1,4 +1,5 @@
 package haxe.test;
+import java.lang.annotation.*;
 
 public class MyClass
 {
@@ -105,4 +106,17 @@ public class MyClass
 			}
 		}
 	}
+
+	@Retention(RetentionPolicy.RUNTIME)
+	public @interface MyAnnotation {
+		String author();
+		int currentRevision() default 1;
+		String lastModified() default "N/A";
+		TEnum someEnum() default TEnum.TC;
+	}
+
+	@Retention(RetentionPolicy.RUNTIME)
+	public @interface ParameterLessAnnotation {
+	}
 }
+

tests/unit/src/unit/TestCSharp.hx

@@ -11,6 +11,7 @@ import haxe.test.IEditableTextBuffer;
 import haxe.test.LowerCaseClass;
 
 import cs.Flags;
+import cs.system.componentmodel.DescriptionAttribute;
 
 import NoPackage;
 #if unsafe
@@ -663,7 +664,7 @@ class TestCSharp extends Test
 	}
 }
 
-@:meta(System.ComponentModel.Description("Type description test"))
+@:strict(DescriptionAttribute("Type description test"))
 typedef StringWithDescription = String;
 
 private class HxClass extends NativeClass
@@ -687,7 +688,7 @@ private class HxClass extends NativeClass
 	}
 }
 
-@:meta(System.ComponentModel.Description("MyClass Description"))
+@:strict(cs.system.componentmodel.DescriptionAttribute("MyClass Description"))
 private class TestMyClass extends haxe.test.MyClass
 {
 	@:overload public function new()
@@ -709,7 +710,7 @@ private class TestMyClass extends haxe.test.MyClass
 	public var dynamicCalled:Bool;
 	public var getCalled:Bool;
 
-	@:meta(System.ComponentModel.Description("Argument description"))
+	@:strict(DescriptionAttribute("Argument description"))
 	@:keep public function argumentDescription(arg:StringWithDescription)
 	{
 	}

tests/unit/src/unit/TestJava.hx

@@ -1,6 +1,7 @@
 package unit;
 import haxe.io.Bytes;
 import haxe.test.Base;
+import haxe.test.MyClass;
 import haxe.test.Base.Base_InnerClass;
 import haxe.test.Base.Base___InnerClass3__;
 import haxe.test.Base.Base___InnerClass3___InnerClass4__;
@@ -10,6 +11,8 @@ import java.util.EnumSet;
 import java.vm.*;
 
 #if java
+@:strict(haxe.test.MyClass.MyClass_MyAnnotation({ author:"John Doe", someEnum: TB }))
+@:strict(MyClass_ParameterLessAnnotation)
 class TestJava extends Test
 {
   function testException()
@@ -26,6 +29,24 @@ class TestJava extends Test
     catch(e:Dynamic) throw e; //shouldn't throw any exception
   }
 
+	@:strict(MyClass_MyAnnotation({ author:"author", currentRevision: 2 }))
+	public function testAnnotations()
+	{
+		var cl = java.Lib.toNativeType(TestJava);
+		var a = cl.getAnnotation(java.Lib.toNativeType(MyClass_MyAnnotation));
+		t(a != null);
+		eq(a.author(), "John Doe");
+		eq(a.someEnum(), TB);
+		eq(a.currentRevision(), 1);
+		t(cl.getAnnotation(java.Lib.toNativeType(MyClass_ParameterLessAnnotation)) != null);
+		var m = cl.getMethod("testAnnotations", new java.NativeArray(0));
+		a = m.getAnnotation(java.Lib.toNativeType(MyClass_MyAnnotation));
+		t(a != null);
+		eq(a.author(), "author");
+		eq(a.someEnum(), TC);
+		eq(a.currentRevision(), 2);
+	}
+
 	function testLowerCase()
 	{
 		var l = new LowerCaseClass();

typeload.ml

@@ -1070,6 +1070,177 @@ let type_function_arg_value ctx t c =
 			in
 			loop e
 
+(**** strict meta ****)
+let get_native_repr md pos =
+	let path, meta = match md with
+		| TClassDecl cl -> cl.cl_path, cl.cl_meta
+		| TEnumDecl e -> e.e_path, e.e_meta
+		| TTypeDecl t -> t.t_path, t.t_meta
+		| TAbstractDecl a -> a.a_path, a.a_meta
+	in
+	let rec loop acc = function
+		| (Meta.JavaCanonical,[EConst(String pack),_; EConst(String name),_],_) :: _ ->
+			ExtString.String.nsplit pack ".", name
+		| (Meta.Native,[EConst(String name),_],_) :: meta ->
+			loop (Ast.parse_path name) meta
+		| _ :: meta ->
+			loop acc meta
+		| [] ->
+			acc
+	in
+	let pack, name = loop path meta in
+	match pack with
+		| [] ->
+			(EConst(Ident(name)), pos)
+		| hd :: tl ->
+			let rec loop pack expr = match pack with
+				| hd :: tl ->
+					loop tl (EField(expr,hd),pos)
+				| [] ->
+					(EField(expr,name),pos)
+			in
+			loop tl (EConst(Ident(hd)),pos)
+
+let rec process_meta_argument ?(toplevel=true) ctx expr = match expr.eexpr with
+	| TField(e,f) ->
+		(EField(process_meta_argument ~toplevel:false ctx e,field_name f),expr.epos)
+	| TConst(TInt i) ->
+		(EConst(Int (Int32.to_string i)), expr.epos)
+	| TConst(TFloat f) ->
+		(EConst(Float f), expr.epos)
+	| TConst(TString s) ->
+		(EConst(String s), expr.epos)
+	| TConst TNull ->
+		(EConst(Ident "null"), expr.epos)
+	| TConst(TBool b) ->
+		(EConst(Ident (string_of_bool b)), expr.epos)
+	| TCast(e,_) | TMeta(_,e) | TParenthesis(e) ->
+		process_meta_argument ~toplevel ctx e
+	| TTypeExpr md when toplevel ->
+		let p = expr.epos in
+		if ctx.com.platform = Cs then
+			(ECall( (EConst(Ident "typeof"), p), [get_native_repr md expr.epos] ), p)
+		else
+			(EField(get_native_repr md expr.epos, "class"), p)
+	| TTypeExpr md ->
+		get_native_repr md expr.epos
+	| _ ->
+		display_error ctx "This expression is too complex to be a strict metadata argument" expr.epos;
+		(EConst(Ident "null"), expr.epos)
+
+let make_meta ctx texpr extra =
+	match texpr.eexpr with
+		| TNew(c,_,el) ->
+			ECall(get_native_repr (TClassDecl c) texpr.epos, (List.map (process_meta_argument ctx) el) @ extra), texpr.epos
+		| TTypeExpr(md) ->
+			ECall(get_native_repr md texpr.epos, extra), texpr.epos
+		| _ ->
+			display_error ctx "Unexpected expression" texpr.epos; assert false
+
+let field_to_type_path ctx e =
+	let rec loop e pack name = match e with
+		| EField(e,f),p when Char.lowercase (String.get f 0) <> String.get f 0 -> (match name with
+			| [] | _ :: [] ->
+				loop e pack (f :: name)
+			| _ -> (* too many name paths *)
+				display_error ctx ("Unexpected " ^ f) p;
+				raise Exit)
+		| EField(e,f),_ ->
+			loop e (f :: pack) name
+		| EConst(Ident f),_ ->
+			let pack, name, sub = match name with
+				| [] ->
+					let fchar = String.get f 0 in
+					if Char.uppercase fchar = fchar then
+						pack, f, None
+					else begin
+						display_error ctx "A class name must start with an uppercase character" (snd e);
+						raise Exit
+					end
+				| [name] ->
+					f :: pack, name, None
+				| [name; sub] ->
+					f :: pack, name, Some sub
+				| _ ->
+					assert false
+			in
+			{ tpackage=pack; tname=name; tparams=[]; tsub=sub }
+		| _,pos ->
+			display_error ctx "Unexpected expression when building strict meta" pos;
+			raise Exit
+	in
+	loop e [] []
+
+let handle_fields ctx fields_to_check with_type_expr =
+	List.map (fun (name,expr) ->
+		let pos = snd expr in
+		let field = (EField(with_type_expr,name), pos) in
+		let fieldexpr = (EConst(Ident name),pos) in
+		let left_side = match ctx.com.platform with
+			| Cs -> field
+			| Java -> (ECall(field,[]),pos)
+			| _ -> assert false
+		in
+
+		let left = type_expr ctx left_side NoValue in
+		let right = type_expr ctx expr (WithType left.etype) in
+		unify ctx left.etype right.etype (snd expr);
+		(EBinop(Ast.OpAssign,fieldexpr,process_meta_argument ctx right), pos)
+	) fields_to_check
+
+let get_strict_meta ctx params pos =
+	let pf = ctx.com.platform in
+	let changed_expr, fields_to_check, ctype = match params with
+		| [ECall(ef, el),p] ->
+			(* check last argument *)
+			let el, fields = match List.rev el with
+				| (EObjectDecl(decl),_) :: el ->
+					List.rev el, decl
+				| _ ->
+					el, []
+			in
+			let tpath = field_to_type_path ctx ef in
+			if pf = Cs then
+				(ENew(tpath, el), p), fields, CTPath tpath
+			else
+				ef, fields, CTPath tpath
+		| [EConst(Ident i),p as expr] ->
+			let tpath = { tpackage=[]; tname=i; tparams=[]; tsub=None } in
+			if pf = Cs then
+				(ENew(tpath, []), p), [], CTPath tpath
+			else
+				expr, [], CTPath tpath
+		| [ (EField(_),p as field) ] ->
+			let tpath = field_to_type_path ctx field in
+			if pf = Cs then
+				(ENew(tpath, []), p), [], CTPath tpath
+			else
+				field, [], CTPath tpath
+		| _ ->
+			display_error ctx "A @:strict metadata must contain exactly one parameter. Please check the documentation for more information" pos;
+			raise Exit
+	in
+	let texpr = type_expr ctx changed_expr NoValue in
+	let with_type_expr = (ECheckType( (EConst (Ident "null"), pos), ctype ), pos) in
+	let extra = handle_fields ctx fields_to_check with_type_expr in
+	Meta.Meta, [make_meta ctx texpr extra], pos
+
+let check_strict_meta ctx metas =
+	let pf = ctx.com.platform in
+	match pf with
+		| Cs | Java ->
+			let ret = ref [] in
+			List.iter (function
+				| Meta.Strict,params,pos -> (try
+					ret := get_strict_meta ctx params pos :: !ret
+				with | Exit -> ())
+				| _ -> ()
+			) metas;
+			!ret
+		| _ -> []
+
+(**** end of strict meta handling *****)
+
 let rec add_constructor ctx c force_constructor p =
 	match c.cl_constructor, c.cl_super with
 	| None, Some ({ cl_constructor = Some cfsup } as csup,cparams) when not c.cl_extern && not (Meta.has Meta.CompilerGenerated cfsup.cf_meta) ->
@@ -2664,6 +2835,21 @@ let rec init_module_type ctx context_init do_init (decl,p) =
 		ctx.pass <- PBuildModule;
 		ctx.curclass <- null_class;
 		delay ctx PBuildClass (fun() -> ignore(c.cl_build()));
+		if (ctx.com.platform = Java || ctx.com.platform = Cs) && not c.cl_extern then
+			delay ctx PTypeField (fun () ->
+				let metas = check_strict_meta ctx c.cl_meta in
+				if metas <> [] then c.cl_meta <- metas @ c.cl_meta;
+				let rec run_field cf =
+					let metas = check_strict_meta ctx cf.cf_meta in
+					if metas <> [] then cf.cf_meta <- metas @ cf.cf_meta;
+					List.iter run_field cf.cf_overloads
+				in
+				List.iter run_field c.cl_ordered_statics;
+				List.iter run_field c.cl_ordered_fields;
+				match c.cl_constructor with
+					| Some f -> run_field f
+					| _ -> ()
+			);
 	| EEnum d ->
 		let e = (match get_type d.d_name with TEnumDecl e -> e | _ -> assert false) in
 		let ctx = { ctx with type_params = e.e_params } in
@@ -2786,6 +2972,16 @@ let rec init_module_type ctx context_init do_init (decl,p) =
 			a_status = ref (EnumStatics e);
 		};
 		if !is_flat then e.e_meta <- (Meta.FlatEnum,[],e.e_pos) :: e.e_meta;
+
+		if (ctx.com.platform = Java || ctx.com.platform = Cs) && not e.e_extern then
+			delay ctx PTypeField (fun () ->
+				let metas = check_strict_meta ctx e.e_meta in
+				e.e_meta <- metas @ e.e_meta;
+				PMap.iter (fun _ ef ->
+					let metas = check_strict_meta ctx ef.ef_meta in
+					if metas <> [] then ef.ef_meta <- metas @ ef.ef_meta
+				) e.e_constrs
+			);
 	| ETypedef d ->
 		let t = (match get_type d.d_name with TTypeDecl t -> t | _ -> assert false) in
 		check_global_metadata ctx (fun m -> t.t_meta <- m :: t.t_meta) t.t_module.m_path t.t_path None;
@@ -2804,6 +3000,11 @@ let rec init_module_type ctx context_init do_init (decl,p) =
 			| None -> r := Some tt;
 			| Some _ -> assert false);
 		| _ -> assert false);
+		if ctx.com.platform = Cs && t.t_meta <> [] then
+			delay ctx PTypeField (fun () ->
+				let metas = check_strict_meta ctx t.t_meta in
+				if metas <> [] then t.t_meta <- metas @ t.t_meta;
+			);
 	| EAbstract d ->
 		let a = (match get_type d.d_name with TAbstractDecl a -> a | _ -> assert false) in
 		check_global_metadata ctx (fun m -> a.a_meta <- m :: a.a_meta) a.a_module.m_path a.a_path None;