quick and dirty POC implementation for HaxeFoundation/haxe-evolution#23

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
@@ -911,7 +912,7 @@ and parse_type_opt = parser
 	| [< t = parse_type_hint >] -> Some t
 	| [< >] -> None
 
-and parse_complex_type s =
+and parse_complex_type ?(allow_named=false) s =
 	let t = parse_complex_type_inner s in
 	parse_complex_type_next t s
 
@@ -920,7 +921,16 @@ and parse_structural_extension = parser
 		t
 
 and parse_complex_type_inner = parser
-	| [< '(POpen,p1); t = parse_complex_type; '(PClose,p2) >] -> CTParent t,punion p1 p2
+	| [< '(POpen,p1); tl = psep Comma (parse_complex_type ~allow_named:true); '(PClose,p2); s >] ->
+		let arg_error p = error (Custom "Unnamed function arguments are not supported") p in
+		(match tl with
+		| [] as rest | ((CTOptional (CTNamed _,_) | CTNamed _), _) :: rest ->
+			List.iter (fun (t,p) -> match t with (CTNamed _ | CTOptional (CTNamed _,_)) -> () | _ -> arg_error p) rest;
+			let t = parse_ctfunction_rest p1 tl s in
+			CTParent t,pos t (* wrap in parens to prevent CTFunction merging *)
+		| [t] ->
+			CTParent t,punion p1 p2
+		| _ -> arg_error (punion p1 p2))
 	| [< '(BrOpen,p1); s >] ->
 		(match s with parser
 		| [< l,p2 = parse_type_anonymous false >] -> CTAnonymous l,punion p1 p2
@@ -933,49 +943,66 @@ 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 >] ->
+			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_ctfunction_rest p1 args = parser
+	| [< '(Arrow,_); ret = parse_complex_type >] ->
+		CTFunction (args,ret),punion p1 (snd ret)
+
 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, name = (match fst t with CTNamed ((n,_),t) -> t, n | _ -> t,"") in
+				name,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 );
 }
 
 /**