Rework functional interface unification again

src-json/meta.json

@@ -336,6 +336,12 @@
 		"targets": ["TAbstractField"],
 		"links": ["https://haxe.org/manual/types-abstract-implicit-casts.html"]
 	},
+	{
+		"name": "FunctionalInterface",
+		"metadata": ":functionalInterface",
+		"doc": "Mark an interface as a functional interface",
+		"platforms": ["jvm"]
+	},
 	{
 		"name": "FunctionCode",
 		"metadata": ":functionCode",

src/codegen/javaModern.ml

@@ -993,6 +993,16 @@ module Converter = struct
 			in
 			add_meta (Meta.Annotation,args,p)
 		end;
+		List.iter (fun attr -> match attr with
+			| AttrVisibleAnnotations ann ->
+				List.iter (function
+					| { ann_type = TObject( (["java";"lang"], "FunctionalInterface"), [] ) } ->
+						add_meta (Meta.FunctionalInterface,[],p);
+					| _ -> ()
+				) ann
+			| _ ->
+				()
+		) jc.jc_attributes;
 		let d = {
 			d_name = (class_name,p);
 			d_doc = None;

src/context/abstractCast.ml

@@ -87,10 +87,19 @@ and do_check_cast ctx uctx tleft eright p =
 						loop2 a.a_to
 					end
 				| TInst(c,tl), TFun _ when has_class_flag c CFunctionalInterface ->
-					let cf = ctx.g.functional_interface_lut#find c.cl_path in
+					let cf = try
+						snd (ctx.com.functional_interface_lut#find c.cl_path)
+					with Not_found -> match TClass.get_singular_interface_field c.cl_ordered_fields with
+						| None ->
+							raise Not_found
+						| Some cf ->
+							ctx.com.functional_interface_lut#add c.cl_path (c,cf);
+							cf
+					in
 					let map = apply_params c.cl_params tl in
 					let monos = Monomorph.spawn_constrained_monos map cf.cf_params in
-					unify_raise_custom uctx eright.etype (map (apply_params cf.cf_params monos cf.cf_type)) p;
+					unify_raise_custom native_unification_context eright.etype (map (apply_params cf.cf_params monos cf.cf_type)) p;
+					if has_mono tright then raise_typing_error ("Cannot use this function as a functional interface because it has unknown types: " ^ (s_type (print_context()) tright)) p;
 					eright
 				| _ ->
 					raise Not_found

src/context/common.ml

@@ -407,6 +407,7 @@ type context = {
 	mutable modules : Type.module_def list;
 	mutable types : Type.module_type list;
 	mutable resources : (string,string) Hashtbl.t;
+	functional_interface_lut : (path,(tclass * tclass_field)) lookup;
 	(* target-specific *)
 	mutable flash_version : float;
 	mutable neko_lib_paths : string list;
@@ -845,6 +846,7 @@ let create compilation_step cs version args display_mode =
 		has_error = false;
 		report_mode = RMNone;
 		is_macro_context = false;
+		functional_interface_lut = new Lookup.hashtbl_lookup;
 		hxb_reader_api = None;
 		hxb_reader_stats = HxbReader.create_hxb_reader_stats ();
 		hxb_writer_config = None;
@@ -901,6 +903,7 @@ let clone com is_macro_context =
 		hxb_reader_api = None;
 		hxb_reader_stats = HxbReader.create_hxb_reader_stats ();
 		std = null_class;
+		functional_interface_lut = new Lookup.hashtbl_lookup;
 		empty_class_path = new ClassPath.directory_class_path "" User;
 		class_paths = new ClassPaths.class_paths;
 	}

src/context/typecore.ml

@@ -120,7 +120,6 @@ type typer_globals = {
 	mutable complete : bool;
 	mutable type_hints : (module_def_display * pos * t) list;
 	mutable load_only_cached_modules : bool;
-	functional_interface_lut : (path,tclass_field) lookup;
 	mutable return_partial_type : bool;
 	mutable build_count : int;
 	mutable t_dynamic_def : Type.t;

src/core/tOther.ml

@@ -431,6 +431,26 @@ module TClass = struct
 			cf.cf_expr <- Some e;
 			c.cl_init <- Some cf
 
+	let get_singular_interface_field fields =
+		let is_normal_field cf =
+			not (has_class_field_flag cf CfDefault) && match cf.cf_kind with
+				| Method MethNormal -> true
+				| _ -> false
+		in
+		let rec loop o l = match l with
+			| cf :: l ->
+				if is_normal_field cf then begin
+					if o = None then
+						loop (Some cf) l
+					else
+						None
+				end else
+					loop o l
+			| [] ->
+				o
+		in
+		loop None fields
+
 	let add_cl_init c e =
 		modify_cl_init c e true
 

src/core/tUnification.ml

@@ -66,6 +66,17 @@ let default_unification_context = {
 	strict_field_kind       = false;
 }
 
+(* Unify like targets (e.g. Java) probably would. *)
+let native_unification_context = {
+	allow_transitive_cast = false;
+	allow_abstract_cast   = false;
+	allow_dynamic_to_cast = false;
+	equality_kind         = EqStrict;
+	equality_underlying   = false;
+	allow_arg_name_mismatch = true;
+	strict_field_kind       = false;
+}
+
 module Monomorph = struct
 	let create () = {
 		tm_type = None;

src/generators/genjvm.ml

@@ -60,6 +60,7 @@ type generation_context = {
 	t_exception : Type.t;
 	t_throwable : Type.t;
 	anon_identification : jsignature tanon_identification;
+	mutable functional_interfaces : (tclass * tclass_field * JvmFunctions.JavaFunctionalInterface.t) list;
 	mutable preprocessor : jsignature preprocessor;
 	default_export_config : export_config;
 	typed_functions : JvmFunctions.typed_functions;
@@ -417,10 +418,31 @@ let generate_equals_function (jc : JvmClass.builder) jsig_arg =
 	save();
 	jm_equals,load
 
-let create_field_closure gctx jc path_this jm name jsig =
+let associate_functional_interfaces gctx f t =
+	if not (has_mono t) then begin
+		List.iter (fun (c,cf,jfi) ->
+			let c_monos = Monomorph.spawn_constrained_monos (fun t -> t) c.cl_params in
+			let map t = apply_params c.cl_params c_monos t in
+			let cf_monos = Monomorph.spawn_constrained_monos map cf.cf_params in
+			try
+				Type.unify_custom native_unification_context t (apply_params cf.cf_params cf_monos (map cf.cf_type));
+				ignore(List.map follow cf_monos);
+				f#add_functional_interface jfi (List.map (jsignature_of_type gctx) c_monos)
+			with Unify_error _ ->
+				()
+		) gctx.functional_interfaces
+	end
+
+let create_field_closure gctx jc path_this jm name jsig t =
 	let jsig_this = object_path_sig path_this in
 	let context = ["this",jsig_this] in
 	let wf = new JvmFunctions.typed_function gctx.typed_functions (FuncMember(path_this,name)) jc jm context in
+	begin match t with
+		| None ->
+			()
+		| Some t ->
+			associate_functional_interfaces gctx wf t
+	end;
 	let jc_closure = wf#get_class in
 	ignore(wf#generate_constructor true);
 	let args,ret = match jsig with
@@ -461,12 +483,12 @@ let create_field_closure gctx jc path_this jm name jsig =
 	write_class gctx jc_closure#get_this_path (jc_closure#export_class gctx.default_export_config);
 	jc_closure#get_this_path
 
-let create_field_closure gctx jc path_this jm name jsig f =
+let create_field_closure gctx jc path_this jm name jsig f t =
 	let jsig_this = object_path_sig path_this in
 	let closure_path = try
 		Hashtbl.find gctx.closure_paths (path_this,name,jsig)
 	with Not_found ->
-		let closure_path = create_field_closure gctx jc path_this jm name jsig in
+		let closure_path = create_field_closure gctx jc path_this jm name jsig t in
 		Hashtbl.add gctx.closure_paths (path_this,name,jsig) closure_path;
 		closure_path
 	in
@@ -576,6 +598,7 @@ class texpr_to_jvm
 			| _ -> None
 		in
 		let wf = new JvmFunctions.typed_function gctx.typed_functions (FuncLocal name) jc jm context in
+		associate_functional_interfaces gctx wf e.etype;
 		let jc_closure = wf#get_class in
 		ignore(wf#generate_constructor (env <> []));
 		let filter = match ret with
@@ -659,12 +682,13 @@ class texpr_to_jvm
 		| None ->
 			default();
 
-	method read_static_closure (path : path) (name : string) (args : (string * jsignature) list) (ret : jsignature option) =
+	method read_static_closure (path : path) (name : string) (args : (string * jsignature) list) (ret : jsignature option) (t : Type.t) =
 		let jsig = method_sig (List.map snd args) ret in
 		let closure_path = try
 			Hashtbl.find gctx.closure_paths (path,name,jsig)
 		with Not_found ->
 			let wf = new JvmFunctions.typed_function gctx.typed_functions (FuncStatic(path,name)) jc jm [] in
+			associate_functional_interfaces gctx wf t;
 			let jc_closure = wf#get_class in
 			ignore(wf#generate_constructor false);
 			let jm_invoke = wf#generate_invoke args ret [] in
@@ -691,7 +715,7 @@ class texpr_to_jvm
 				| TFun(tl,tr) -> List.map (fun (n,_,t) -> n,self#vtype t) tl,(return_of_type gctx tr)
 				| _ -> die "" __LOC__
 			in
-			self#read_static_closure path cf.cf_name args ret
+			self#read_static_closure path cf.cf_name args ret cf.cf_type
 		in
 		let dynamic_read s =
 			self#texpr rvalue_any e1;
@@ -738,7 +762,7 @@ class texpr_to_jvm
 			else
 				create_field_closure gctx jc c.cl_path jm cf.cf_name (self#vtype cf.cf_type) (fun () ->
 					self#texpr rvalue_any e1;
-				)
+				) (Some cf.cf_type)
 
 	method read_write ret ak e (f : unit -> unit) =
 		let apply dup =
@@ -2209,7 +2233,7 @@ let generate_dynamic_access gctx (jc : JvmClass.builder) fields is_anon =
 			begin match kind,jsig with
 				| Method (MethNormal | MethInline),TMethod(args,_) ->
 					if gctx.dynamic_level >= 2 then begin
-						create_field_closure gctx jc jc#get_this_path jm name jsig (fun () -> jm#load_this)
+						create_field_closure gctx jc jc#get_this_path jm name jsig (fun () -> jm#load_this) None
 					end else begin
 						jm#load_this;
 						jm#string name;
@@ -2942,7 +2966,7 @@ module Preprocessor = struct
 		end else if fst mt.mt_path = [] then
 			mt.mt_path <- make_root mt.mt_path
 
-	let check_single_method_interface gctx c =
+	let check_functional_interface gctx c =
 		let rec loop m l = match l with
 			| [] ->
 				m
@@ -2961,7 +2985,8 @@ module Preprocessor = struct
 		| Some cf ->
 			match jsignature_of_type gctx cf.cf_type with
 			| TMethod(args,ret) ->
-				JvmFunctions.JavaFunctionalInterfaces.add args ret c.cl_path cf.cf_name (List.map extract_param_name (c.cl_params @ cf.cf_params));
+				let jfi = JvmFunctions.JavaFunctionalInterface.create args ret c.cl_path cf.cf_name (List.map extract_param_name (c.cl_params @ cf.cf_params)) in
+				gctx.functional_interfaces <- (c,cf,jfi) :: gctx.functional_interfaces;
 			| _ ->
 				()
 
@@ -2993,8 +3018,10 @@ module Preprocessor = struct
 		List.iter (fun mt ->
 			match mt with
 			| TClassDecl c ->
-				if not (has_class_flag c CInterface) then gctx.preprocessor#preprocess_class c
-				else check_single_method_interface gctx c;
+				if not (has_class_flag c CInterface) then
+					gctx.preprocessor#preprocess_class c
+				else if has_class_flag c CFunctionalInterface then
+					check_functional_interface gctx c
 			| _ -> ()
 		) gctx.com.types;
 		(* find typedef-interface implementations *)
@@ -3070,6 +3097,7 @@ let generate jvm_flag com =
 		timer = new Timer.timer ["generate";"java"];
 		jar_compression_level = compression_level;
 		dynamic_level = dynamic_level;
+		functional_interfaces = [];
 	} in
 	gctx.preprocessor <- new preprocessor com.basic (jsignature_of_type gctx);
 	gctx.typedef_interfaces <- new typedef_interfaces gctx.preprocessor#get_infos anon_identification;