support argument names in function type (closes #4799)

Author: nadako

src/macro/macroApi.ml

@@ -425,6 +425,8 @@ and encode_ctype t =
 		4, [encode_array (List.map encode_path tl); encode_array (List.map encode_field fields)]
 	| CTOptional t ->
 		5, [encode_ctype t]
+	| CTNamed (n,t) ->
+		6, [encode_placed_name n; encode_ctype t]
 	in
 	encode_enum ~pos:(Some (pos t)) ICType tag pl
 
@@ -723,6 +725,8 @@ and decode_ctype t =
 		CTExtend (List.map decode_path (decode_array tl), List.map decode_field (decode_array fl))
 	| 5, [t] ->
 		CTOptional (decode_ctype t)
+	| 6, [n;t] ->
+		CTNamed ((decode_string n,p), decode_ctype t)
 	| _ ->
 		raise Invalid_expr),p
 

src/syntax/ast.ml

@@ -155,6 +155,7 @@ and complex_type =
 	| CTParent of type_hint
 	| CTExtend of placed_type_path list * class_field list
 	| CTOptional of type_hint
+	| CTNamed of placed_name * type_hint
 
 and type_hint = complex_type * pos
 
@@ -550,7 +551,8 @@ let map_expr loop (e,p) =
 			let tl = List.map tpath tl in
 			let fl = List.map cfield fl in
 			CTExtend (tl,fl)
-		| CTOptional t -> CTOptional (type_hint t)),p
+		| CTOptional t -> CTOptional (type_hint t)
+		| CTNamed (n,t) -> CTNamed (n, type_hint t)),p
 	and tparamdecl t =
 		let constraints = List.map type_hint t.tp_constraints in
 		let params = List.map tparamdecl t.tp_params in
@@ -749,6 +751,7 @@ let s_expr e =
 		| CTAnonymous fl -> "{ " ^ String.concat "; " (List.map (s_class_field tabs) fl) ^ "}";
 		| CTParent(t,_) -> "(" ^ s_complex_type tabs t ^ ")"
 		| CTOptional(t,_) -> "?" ^ s_complex_type tabs t
+		| CTNamed ((n,_),(t,_)) -> n ^ " : " ^ s_complex_type tabs t
 		| CTExtend (tl, fl) -> "{> " ^ String.concat " >, " (List.map (s_complex_type_path tabs) tl) ^ ", " ^ String.concat ", " (List.map (s_class_field tabs) fl) ^ " }"
 	and s_class_field tabs f =
 		match f.cff_doc with

src/syntax/parser.mly

@@ -281,6 +281,7 @@ let reify in_macro =
 		| CTParent t -> ct "TParent" [to_type_hint t p]
 		| CTExtend (tl,fields) -> ct "TExtend" [to_array to_tpath tl p; to_array to_cfield fields p]
 		| CTOptional t -> ct "TOptional" [to_type_hint t p]
+		| CTNamed (n,t) -> ct "TNamed" [to_placed_name n; to_type_hint t p]
 	and to_type_hint (t,p) _ =
 		(* to_obj ["type",to_ctype t p;"pos",to_pos p] p *)
 		to_ctype (t,p) p
@@ -933,49 +934,63 @@ and parse_complex_type_inner = parser
 		| [< >] -> serror())
 	| [< '(Question,p1); t,p2 = parse_complex_type_inner >] ->
 		CTOptional (t,p2),punion p1 p2
+	| [< n = dollar_ident; s >] ->
+		(match s with parser
+		| [< '(DblDot,_); t = parse_complex_type_inner >] ->
+			let p1 = snd n in
+			let p2 = snd t in
+			CTNamed (n,t),punion p1 p2
+		| [< s >] ->
+			let n,p = n in
+			let t,p = parse_type_path2 None [] n p s in
+			CTPath t,p
+			)
 	| [< t,p = parse_type_path >] ->
 		CTPath t,p
 
 and parse_type_path s = parse_type_path1 None [] s
 
 and parse_type_path1 p0 pack = parser
 	| [< name, p1 = dollar_ident_macro pack; s >] ->
-		if is_lower_ident name then
-			(match s with parser
-			| [< '(Dot,p) >] ->
-				if is_resuming p then
-					raise (TypePath (List.rev (name :: pack),None,false))
-				else
-					parse_type_path1 (match p0 with None -> Some p1 | Some _ -> p0) (name :: pack) s
-			| [< '(Semicolon,_) >] ->
-				error (Custom "Type name should start with an uppercase letter") p1
-			| [< >] -> serror())
-		else
-			let sub,p2 = (match s with parser
-				| [< '(Dot,p); s >] ->
-					(if is_resuming p then
-						raise (TypePath (List.rev pack,Some (name,false),false))
-					else match s with parser
-						| [< '(Const (Ident name),p2) when not (is_lower_ident name) >] -> Some name,p2
-						| [< '(Binop OpOr,_) when do_resume() >] ->
-							set_resume p;
-							raise (TypePath (List.rev pack,Some (name,false),false))
-						| [< >] -> serror())
-				| [< >] -> None,p1
-			) in
-			let params,p2 = (match s with parser
-				| [< '(Binop OpLt,_); l = psep Comma parse_type_path_or_const; '(Binop OpGt,p2) >] -> l,p2
-				| [< >] -> [],p2
-			) in
-			{
-				tpackage = List.rev pack;
-				tname = name;
-				tparams = params;
-				tsub = sub;
-			},punion (match p0 with None -> p1 | Some p -> p) p2
+		parse_type_path2 p0 pack name p1 s
 	| [< '(Binop OpOr,_) when do_resume() >] ->
 		raise (TypePath (List.rev pack,None,false))
 
+and parse_type_path2 p0 pack name p1 s =
+	if is_lower_ident name then
+		(match s with parser
+		| [< '(Dot,p) >] ->
+			if is_resuming p then
+				raise (TypePath (List.rev (name :: pack),None,false))
+			else
+				parse_type_path1 (match p0 with None -> Some p1 | Some _ -> p0) (name :: pack) s
+		| [< '(Semicolon,_) >] ->
+			error (Custom "Type name should start with an uppercase letter") p1
+		| [< >] -> serror())
+	else
+		let sub,p2 = (match s with parser
+			| [< '(Dot,p); s >] ->
+				(if is_resuming p then
+					raise (TypePath (List.rev pack,Some (name,false),false))
+				else match s with parser
+					| [< '(Const (Ident name),p2) when not (is_lower_ident name) >] -> Some name,p2
+					| [< '(Binop OpOr,_) when do_resume() >] ->
+						set_resume p;
+						raise (TypePath (List.rev pack,Some (name,false),false))
+					| [< >] -> serror())
+			| [< >] -> None,p1
+		) in
+		let params,p2 = (match s with parser
+			| [< '(Binop OpLt,_); l = psep Comma parse_type_path_or_const; '(Binop OpGt,p2) >] -> l,p2
+			| [< >] -> [],p2
+		) in
+		{
+			tpackage = List.rev pack;
+			tname = name;
+			tparams = params;
+			tsub = sub;
+		},punion (match p0 with None -> p1 | Some p -> p) p2
+
 and type_name = parser
 	| [< '(Const (Ident name),p) >] ->
 		if is_lower_ident name then

src/typing/typeload.ml

@@ -547,6 +547,7 @@ and load_complex_type ctx allow_display p (t,pn) =
 	| CTParent t -> load_complex_type ctx allow_display p t
 	| CTPath t -> load_instance ~allow_display ctx (t,pn) false p
 	| CTOptional _ -> error "Optional type not allowed here" p
+	| CTNamed _ -> error "Named type not allowed here" p
 	| CTExtend (tl,l) ->
 		(match load_complex_type ctx allow_display p (CTAnonymous l,p) with
 		| TAnon a as ta ->
@@ -687,7 +688,8 @@ and load_complex_type ctx allow_display p (t,pn) =
 		| _ ->
 			TFun (List.map (fun t ->
 				let t, opt = (match fst t with CTOptional t -> t, true | _ -> t,false) in
-				"",opt,load_complex_type ctx allow_display p t
+				let t, n = (match fst t with CTNamed (n,t) -> t,fst n | _ -> t,"") in
+				n,opt,load_complex_type ctx allow_display p t
 			) args,load_complex_type ctx allow_display p r)
 
 and init_meta_overloads ctx co cf =

std/haxe/macro/Expr.hx

@@ -535,6 +535,11 @@ enum ComplexType {
 		Represents an optional type.
 	**/
 	TOptional( t : ComplexType );
+
+	/**
+		Represents a named type.
+	**/
+	TNamed( n : String, t : ComplexType );
 }
 
 /**

std/haxe/macro/Printer.hx

@@ -119,6 +119,7 @@ class Printer {
 		case TAnonymous(fields): "{ " + [for (f in fields) printField(f) + "; "].join("") + "}";
 		case TParent(ct): "(" + printComplexType(ct) + ")";
 		case TOptional(ct): "?" + printComplexType(ct);
+		case TNamed(n,ct): n + ":" + printComplexType(ct);
 		case TExtend(tpl, fields): '{> ${tpl.map(printTypePath).join(" >, ")}, ${fields.map(printField).join(", ")} }';
 	}
 

tests/unit/src/unit/HelperMacros.hx

@@ -7,6 +7,12 @@ class HelperMacros {
 		return macro $v { Std.string(Date.now()) };
 	}
 
+	static public macro function typeString(e) {
+		var typed = haxe.macro.Context.typeExpr(e);
+		var s = haxe.macro.TypeTools.toString(typed.t);
+		return macro $v{s};
+	}
+
 	static public macro function typedAs(actual:haxe.macro.Expr, expected:haxe.macro.Expr) {
 		var tExpected = haxe.macro.Context.typeof(expected);
 		var tActual = haxe.macro.Context.typeof(actual);

tests/unit/src/unit/issues/Issue2958.hx

@@ -1,5 +1,7 @@
 package unit.issues;
 
+import unit.HelperMacros.typeString;
+
 private typedef Asset<@:const T> = String;
 
 class Issue2958 extends Test {
@@ -9,11 +11,4 @@ class Issue2958 extends Test {
 		   "unit.issues._Issue2958.Asset<[\"test\", 1]>"
 		);
 	}
-
-	static macro function typeString(e)
-	{
-		var typed = haxe.macro.Context.typeExpr(e);
-		var s = haxe.macro.TypeTools.toString(typed.t);
-		return macro $v{s};
-	}
 }

tests/unit/src/unit/issues/Issue4799.hx

@@ -0,0 +1,16 @@
+package unit.issues;
+
+import unit.HelperMacros.typeErrorText;
+import unit.HelperMacros.typeString;
+
+class Issue4799 extends Test {
+	function test() {
+		var f : arg1:Int->?arg2:String->Float->Void;
+		eq(typeString(f), "arg1 : Int -> ?arg2 : String -> Float -> Void");
+
+		eq(typeErrorText((null : arg:Int)), "Named type not allowed here");
+
+		// TODO: maybe we could actually allow this?
+		eq(typeErrorText((null : Int->returnValue:Int)), "Named type not allowed here");
+	}
+}