Browse Source

[typer] refactor abstract field meta handling

closes #11237
Simon Krajewski 2 years ago
parent
commit
c2932ab8aa

+ 176 - 157
src/typing/typeloadFields.ml

@@ -1052,165 +1052,179 @@ let create_variable (ctx,cctx,fctx) c f t eo p =
 	TypeBinding.bind_var ctx cctx fctx cf eo;
 	cf
 
-let check_abstract (ctx,cctx,fctx) c cf fd t ret p =
-	match cctx.abstract with
-		| Some a ->
-			let m = mk_mono() in
-			let ta = TAbstract(a,List.map (fun _ -> mk_mono()) a.a_params) in
-			let tthis = if fctx.is_abstract_member || Meta.has Meta.To cf.cf_meta then monomorphs a.a_params a.a_this else a.a_this in
-			let allows_no_expr = ref (Meta.has Meta.CoreType a.a_meta) in
-			let allow_no_expr () = if not (has_class_field_flag cf CfExtern) then begin
-				allows_no_expr := true;
-				fctx.expr_presence_matters <- true;
-			end in
-			let rec loop ml =
-				(match ml with
-				| (Meta.From,_,_) :: _ ->
-					let r = exc_protect ctx (fun r ->
-						r := lazy_processing (fun () -> t);
-						(* the return type of a from-function must be the abstract, not the underlying type *)
-						if not fctx.is_macro then (try type_eq EqStrict ret ta with Unify_error l -> raise_typing_error_ext (make_error (Unify l) p));
-						match t with
-							| TFun([_,_,t],_) -> t
-							| TFun([(_,_,t1);(_,true,t2)],_) when is_pos_infos t2 -> t1
-							| _ -> raise_typing_error ("@:from cast functions must accept exactly one argument") p
-					) "@:from" in
-					a.a_from_field <- (TLazy r,cf) :: a.a_from_field;
-				| (Meta.To,_,_) :: _ ->
-					if fctx.is_macro then invalid_modifier ctx.com fctx "macro" "cast function" p;
-					let are_valid_args args =
-						match args with
-						| [_] -> true
-						| [_; (_,true,t)] when is_pos_infos t -> true
-						| _ -> false
-					in
-					(match cf.cf_kind, cf.cf_type with
-					| Var _, _ ->
-						raise_typing_error "Invalid metadata: @:to must be used on method of abstract" p
-					| Method _, TFun(args, _) when not fctx.is_abstract_member && not (are_valid_args args) ->
-						if not (Meta.has Meta.MultiType a.a_meta) then (* TODO: get rid of this check once multitype is removed *)
-						raise_typing_error "static @:to method should have one argument" p
-					| Method _, TFun(args, _) when fctx.is_abstract_member && not (are_valid_args args) ->
-						if not (Meta.has Meta.MultiType a.a_meta) then (* TODO: get rid of this check once multitype is removed *)
-						raise_typing_error "@:to method should have no arguments" p
-					| _ -> ()
-					);
-					(* TODO: this doesn't seem quite right... *)
-					if not (has_class_field_flag cf CfImpl) then add_class_field_flag cf CfImpl;
-					let resolve_m args =
-						(try unify_raise t (tfun (tthis :: args) m) cf.cf_pos with Error ({ err_message = Unify l; } as err) -> raise_typing_error_ext err);
-						match follow m with
-							| TMono _ when (match t with TFun(_,r) -> r == t_dynamic | _ -> false) -> t_dynamic
-							| m -> m
-					in
-					let is_multitype_cast = Meta.has Meta.MultiType a.a_meta && not fctx.is_abstract_member in
-					if is_multitype_cast && not (Meta.has Meta.MultiType cf.cf_meta) then
-						cf.cf_meta <- (Meta.MultiType,[],null_pos) :: cf.cf_meta;
-					let r = exc_protect ctx (fun r ->
-						r := lazy_processing (fun () -> t);
-						let args = if is_multitype_cast then begin
-							let ctor = try
-								PMap.find "_new" c.cl_statics
-							with Not_found ->
-								raise_typing_error "Constructor of multi-type abstract must be defined before the individual @:to-functions are" cf.cf_pos
-							in
-							(* delay ctx PFinal (fun () -> unify ctx m tthis f.cff_pos); *)
-							let args = match follow (monomorphs a.a_params ctor.cf_type) with
-								| TFun(args,_) -> List.map (fun (_,_,t) -> t) args
-								| _ -> die "" __LOC__
-							in
-							args
-						end else
-							match cf.cf_type with
-							| TFun([_;(_,true,t)],_) when is_pos_infos t -> [t]
-							| _ -> []
-						in
-						let t = resolve_m args in
-						t
-					) "@:to" in
-					a.a_to_field <- (TLazy r, cf) :: a.a_to_field
-				| ((Meta.ArrayAccess,_,_) | (Meta.Op,[(EArrayDecl _),_],_)) :: _ ->
-					if fctx.is_macro then invalid_modifier ctx.com fctx "macro" "array-access function" p;
-					a.a_array <- cf :: a.a_array;
-					allow_no_expr();
-				| (Meta.Op,[EBinop(OpAssign,_,_),_],_) :: _ ->
-					raise_typing_error "Assignment overloading is not supported" p;
-				| (Meta.Op,[EBinop(OpAssignOp OpNullCoal,_,_),_],_) :: _
-				| (Meta.Op,[EBinop(OpNullCoal,_,_),_],_) :: _ ->
-					raise_typing_error "Null coalescing overloading is not supported" p;
-				| (Meta.Op,[ETernary(_,_,_),_],_) :: _ ->
-					raise_typing_error "Ternary overloading is not supported" p;
-				| (Meta.Op,[EBinop(op,_,_),_],_) :: _ ->
-					if fctx.is_macro then invalid_modifier ctx.com fctx "macro" "operator function" p;
-					let targ = if fctx.is_abstract_member then tthis else ta in
-					let left_eq,right_eq =
-						match follow t with
-						| TFun([(_,_,t1);(_,_,t2)],_) ->
-							type_iseq targ t1,type_iseq targ t2
-						| TFun([(_,_,t1);(_,_,t2);(_,true,t3)],_) when is_pos_infos t3 ->
-							type_iseq targ t1,type_iseq targ t2
-						| _ ->
-							if fctx.is_abstract_member then
-								raise_typing_error ("Member @:op functions must accept exactly one argument") cf.cf_pos
-							else
-								raise_typing_error ("Static @:op functions must accept exactly two arguments") cf.cf_pos
-					in
-					if not (left_eq || right_eq) then raise_typing_error ("The left or right argument type must be " ^ (s_type (print_context()) targ)) cf.cf_pos;
-					if right_eq && Meta.has Meta.Commutative cf.cf_meta then raise_typing_error ("Invalid metadata: @:commutative is only allowed if the right argument is not " ^ (s_type (print_context()) targ)) cf.cf_pos;
-					a.a_ops <- (op,cf) :: a.a_ops;
-					allow_no_expr();
-				| (Meta.Op,[EUnop(op,flag,_),_],_) :: _ ->
-					if fctx.is_macro then invalid_modifier ctx.com fctx "macro" "operator function" p;
-					let targ = if fctx.is_abstract_member then tthis else ta in
-					(try type_eq EqStrict t (tfun [targ] (mk_mono())) with Unify_error l -> raise_error_msg (Unify l) cf.cf_pos);
-					a.a_unops <- (op,flag,cf) :: a.a_unops;
-					allow_no_expr();
-				| (Meta.Op,[ECall _,_],_) :: _ ->
-					begin match a.a_call with
-					| None ->
-						a.a_call <- Some cf
-					| Some cf' ->
-						cf'.cf_overloads <- cf :: cf'.cf_overloads
-					end;
-					allow_no_expr();
-				| ((Meta.Resolve,_,_) | (Meta.Op,[EField _,_],_)) :: _ ->
-					let targ = if fctx.is_abstract_member then tthis else ta in
-					let check_fun t1 t2 =
-						if not fctx.is_macro then begin
-							if not (type_iseq targ t1) then raise_typing_error ("First argument type must be " ^ (s_type (print_context()) targ)) cf.cf_pos;
-							if not (type_iseq ctx.t.tstring t2) then raise_typing_error ("Second argument type must be String") cf.cf_pos
-						end
-					in
-					begin match follow t with
-						| TFun((_,_,t1) :: (_,_,t2) :: args,_) when is_empty_or_pos_infos args ->
-							if a.a_read <> None then raise_typing_error "Multiple resolve-read methods are not supported" cf.cf_pos;
-							check_fun t1 t2;
-							a.a_read <- Some cf;
-						| TFun((_,_,t1) :: (_,_,t2) :: (_,_,t3) :: args,_) when is_empty_or_pos_infos args ->
-							if a.a_write <> None then raise_typing_error "Multiple resolve-write methods are not supported" cf.cf_pos;
-							check_fun t1 t2;
-							a.a_write <- Some cf;
-						| _ ->
-							raise_typing_error ("Field type of resolve must be " ^ (s_type (print_context()) targ) ^ " -> String -> T") cf.cf_pos
-					end;
-				| _ -> ());
-				match ml with
-				| _ :: ml -> loop ml
-				| [] -> ()
+let check_abstract (ctx,cctx,fctx) a c cf fd t ret p =
+	let m = mk_mono() in
+	let ta = TAbstract(a,List.map (fun _ -> mk_mono()) a.a_params) in
+	let tthis = if fctx.is_abstract_member || Meta.has Meta.To cf.cf_meta then monomorphs a.a_params a.a_this else a.a_this in
+	let allows_no_expr = ref (Meta.has Meta.CoreType a.a_meta) in
+	let allow_no_expr () = if not (has_class_field_flag cf CfExtern) then begin
+		allows_no_expr := true;
+		fctx.expr_presence_matters <- true;
+	end in
+	let handle_from () =
+		let r = exc_protect ctx (fun r ->
+			r := lazy_processing (fun () -> t);
+			(* the return type of a from-function must be the abstract, not the underlying type *)
+			if not fctx.is_macro then (try type_eq EqStrict ret ta with Unify_error l -> raise_typing_error_ext (make_error (Unify l) p));
+			match t with
+				| TFun([_,_,t],_) -> t
+				| TFun([(_,_,t1);(_,true,t2)],_) when is_pos_infos t2 -> t1
+				| _ -> raise_typing_error ("@:from cast functions must accept exactly one argument") p
+		) "@:from" in
+		a.a_from_field <- (TLazy r,cf) :: a.a_from_field;
+	in
+	let handle_to () =
+		if fctx.is_macro then invalid_modifier ctx.com fctx "macro" "cast function" p;
+		let are_valid_args args =
+			match args with
+			| [_] -> true
+			| [_; (_,true,t)] when is_pos_infos t -> true
+			| _ -> false
+		in
+		(match cf.cf_kind, cf.cf_type with
+		| Var _, _ ->
+			raise_typing_error "Invalid metadata: @:to must be used on method of abstract" p
+		| Method _, TFun(args, _) when not fctx.is_abstract_member && not (are_valid_args args) ->
+			if not (Meta.has Meta.MultiType a.a_meta) then (* TODO: get rid of this check once multitype is removed *)
+			raise_typing_error "static @:to method should have one argument" p
+		| Method _, TFun(args, _) when fctx.is_abstract_member && not (are_valid_args args) ->
+			if not (Meta.has Meta.MultiType a.a_meta) then (* TODO: get rid of this check once multitype is removed *)
+			raise_typing_error "@:to method should have no arguments" p
+		| _ -> ()
+		);
+		(* TODO: this doesn't seem quite right... *)
+		if not (has_class_field_flag cf CfImpl) then add_class_field_flag cf CfImpl;
+		let resolve_m args =
+			(try unify_raise t (tfun (tthis :: args) m) cf.cf_pos with Error ({ err_message = Unify l; } as err) -> raise_typing_error_ext err);
+			match follow m with
+				| TMono _ when (match t with TFun(_,r) -> r == t_dynamic | _ -> false) -> t_dynamic
+				| m -> m
+		in
+		let is_multitype_cast = Meta.has Meta.MultiType a.a_meta && not fctx.is_abstract_member in
+		if is_multitype_cast && not (Meta.has Meta.MultiType cf.cf_meta) then
+			cf.cf_meta <- (Meta.MultiType,[],null_pos) :: cf.cf_meta;
+		let r = exc_protect ctx (fun r ->
+			r := lazy_processing (fun () -> t);
+			let args = if is_multitype_cast then begin
+				let ctor = try
+					PMap.find "_new" c.cl_statics
+				with Not_found ->
+					raise_typing_error "Constructor of multi-type abstract must be defined before the individual @:to-functions are" cf.cf_pos
+				in
+				(* delay ctx PFinal (fun () -> unify ctx m tthis f.cff_pos); *)
+				let args = match follow (monomorphs a.a_params ctor.cf_type) with
+					| TFun(args,_) -> List.map (fun (_,_,t) -> t) args
+					| _ -> die "" __LOC__
+				in
+				args
+			end else
+				match cf.cf_type with
+				| TFun([_;(_,true,t)],_) when is_pos_infos t -> [t]
+				| _ -> []
 			in
-			loop cf.cf_meta;
-			if cf.cf_name = "_new" && Meta.has Meta.MultiType a.a_meta then fctx.do_bind <- false;
-			if fd.f_expr = None then begin
-				if fctx.is_inline then missing_expression ctx.com fctx "Inline functions must have an expression" cf.cf_pos;
-				if fd.f_type = None then raise_typing_error ("Functions without expressions must have an explicit return type") cf.cf_pos;
-				if !allows_no_expr then begin
-					cf.cf_meta <- (Meta.NoExpr,[],null_pos) :: cf.cf_meta;
-					fctx.do_bind <- false;
-					if not (Meta.has Meta.CoreType a.a_meta) then fctx.do_add <- false;
-				end
+			let t = resolve_m args in
+			t
+		) "@:to" in
+		a.a_to_field <- (TLazy r, cf) :: a.a_to_field
+	in
+	let handle_array_access () =
+		if fctx.is_macro then invalid_modifier ctx.com fctx "macro" "array-access function" p;
+		a.a_array <- cf :: a.a_array;
+		allow_no_expr();
+	in
+	let handle_resolve () =
+		let targ = if fctx.is_abstract_member then tthis else ta in
+		let check_fun t1 t2 =
+			if not fctx.is_macro then begin
+				if not (type_iseq targ t1) then raise_typing_error ("First argument type must be " ^ (s_type (print_context()) targ)) cf.cf_pos;
+				if not (type_iseq ctx.t.tstring t2) then raise_typing_error ("Second argument type must be String") cf.cf_pos
 			end
+		in
+		begin match follow t with
+			| TFun((_,_,t1) :: (_,_,t2) :: args,_) when is_empty_or_pos_infos args ->
+				if a.a_read <> None then raise_typing_error "Multiple resolve-read methods are not supported" cf.cf_pos;
+				check_fun t1 t2;
+				a.a_read <- Some cf;
+			| TFun((_,_,t1) :: (_,_,t2) :: (_,_,t3) :: args,_) when is_empty_or_pos_infos args ->
+				if a.a_write <> None then raise_typing_error "Multiple resolve-write methods are not supported" cf.cf_pos;
+				check_fun t1 t2;
+				a.a_write <- Some cf;
+			| _ ->
+				raise_typing_error ("Field type of resolve must be " ^ (s_type (print_context()) targ) ^ " -> String -> T") cf.cf_pos
+		end;
+	in
+	let handle_op e = match fst e with
+		| (EArrayDecl _) ->
+			handle_array_access()
+		| EBinop(OpAssign,_,_) ->
+			raise_typing_error "Assignment overloading is not supported" p;
+		| EBinop(OpAssignOp OpNullCoal,_,_)
+		| EBinop(OpNullCoal,_,_) ->
+			raise_typing_error "Null coalescing overloading is not supported" p;
+		| ETernary(_,_,_) ->
+			raise_typing_error "Ternary overloading is not supported" p;
+		| EBinop(op,_,_) ->
+			if fctx.is_macro then invalid_modifier ctx.com fctx "macro" "operator function" p;
+			let targ = if fctx.is_abstract_member then tthis else ta in
+			let left_eq,right_eq =
+				match follow t with
+				| TFun([(_,_,t1);(_,_,t2)],_) ->
+					type_iseq targ t1,type_iseq targ t2
+				| TFun([(_,_,t1);(_,_,t2);(_,true,t3)],_) when is_pos_infos t3 ->
+					type_iseq targ t1,type_iseq targ t2
+				| _ ->
+					if fctx.is_abstract_member then
+						raise_typing_error ("Member @:op functions must accept exactly one argument") cf.cf_pos
+					else
+						raise_typing_error ("Static @:op functions must accept exactly two arguments") cf.cf_pos
+			in
+			if not (left_eq || right_eq) then raise_typing_error ("The left or right argument type must be " ^ (s_type (print_context()) targ)) cf.cf_pos;
+			if right_eq && Meta.has Meta.Commutative cf.cf_meta then raise_typing_error ("Invalid metadata: @:commutative is only allowed if the right argument is not " ^ (s_type (print_context()) targ)) cf.cf_pos;
+			a.a_ops <- (op,cf) :: a.a_ops;
+			allow_no_expr();
+		| EUnop(op,flag,_) ->
+			if fctx.is_macro then invalid_modifier ctx.com fctx "macro" "operator function" p;
+			let targ = if fctx.is_abstract_member then tthis else ta in
+			(try type_eq EqStrict t (tfun [targ] (mk_mono())) with Unify_error l -> raise_error_msg (Unify l) cf.cf_pos);
+			a.a_unops <- (op,flag,cf) :: a.a_unops;
+			allow_no_expr();
+		| ECall _ ->
+			begin match a.a_call with
+			| None ->
+				a.a_call <- Some cf
+			| Some cf' ->
+				cf'.cf_overloads <- cf :: cf'.cf_overloads
+			end;
+			allow_no_expr();
+		| EField _ ->
+			handle_resolve()
 		| _ ->
-			()
+			raise_typing_error ("Invalid @:op expresssions, should be an operator or a call") (pos e)
+	in
+	let check_meta m = match m with
+		| (Meta.From,_,_) ->
+			handle_from()
+		| (Meta.To,_,_) ->
+			handle_to()
+		| (Meta.Op,[e],_) ->
+			handle_op e
+		| (Meta.ArrayAccess,_,_) ->
+			handle_array_access()
+		| (Meta.Resolve,_,_) ->
+			handle_resolve()
+		| _ -> ();
+	in
+	List.iter check_meta cf.cf_meta;
+	if cf.cf_name = "_new" && Meta.has Meta.MultiType a.a_meta then fctx.do_bind <- false;
+	if fd.f_expr = None then begin
+		if fctx.is_inline then missing_expression ctx.com fctx "Inline functions must have an expression" cf.cf_pos;
+		if fd.f_type = None then raise_typing_error ("Functions without expressions must have an explicit return type") cf.cf_pos;
+		if !allows_no_expr then begin
+			cf.cf_meta <- (Meta.NoExpr,[],null_pos) :: cf.cf_meta;
+			fctx.do_bind <- false;
+			if not (Meta.has Meta.CoreType a.a_meta) then fctx.do_add <- false;
+		end
+	end
 
 let type_opt (ctx,cctx,fctx) p t =
 	let c = cctx.tclass in
@@ -1428,7 +1442,12 @@ let create_method (ctx,cctx,fctx) c f fd p =
 				()
 	) parent;
 	generate_args_meta ctx.com (Some c) (fun meta -> cf.cf_meta <- meta :: cf.cf_meta) fd.f_args;
-	check_abstract (ctx,cctx,fctx) c cf fd t ret p;
+	begin match cctx.abstract with
+	| Some a ->
+		check_abstract (ctx,cctx,fctx) a c cf fd t ret p;
+	| _ ->
+		()
+	end;
 	init_meta_overloads ctx (Some c) cf;
 	ctx.curfield <- cf;
 	if fctx.do_bind then

+ 5 - 0
tests/misc/projects/Issue11237/Main.hx

@@ -0,0 +1,5 @@
+abstract A(Int) {
+	@:op(a) function bar() {}
+}
+
+function main() {}

+ 1 - 0
tests/misc/projects/Issue11237/compile-fail.hxml

@@ -0,0 +1 @@
+--main Main

+ 1 - 0
tests/misc/projects/Issue11237/compile-fail.hxml.stderr

@@ -0,0 +1 @@
+Main.hx:2: characters 7-8 : Invalid @:op expresssions, should be an operator or a call