basic GADT support : type parameters and explicit return type on enum constructors (fixed issue #1288)

ast.ml

@@ -247,7 +247,15 @@ type abstract_flag =
 	| ASubType of complex_type
 	| ASuperType of complex_type
 
-type enum_constructor = string * documentation * metadata * (string * bool * complex_type) list * pos
+type enum_constructor = {
+	ec_name : string;
+	ec_doc : documentation;
+	ec_meta : metadata;
+	ec_args : (string * bool * complex_type) list;
+	ec_pos : pos;
+	ec_params : type_param list;
+	ec_type : complex_type option;
+}
 
 type ('a,'b) definition = {
 	d_name : string;
@@ -483,7 +491,7 @@ let map_expr loop (e,p) =
 	let rec tparam = function
 		| TPType t -> TPType (ctype t)
 		| TPExpr e -> TPExpr (loop e)
-	and cfield f = 
+	and cfield f =
 		{ f with cff_kind = (match f.cff_kind with
 			| FVar (t,e) -> FVar (opt ctype t, opt loop e)
 			| FFun f -> FFun (func f)
@@ -499,7 +507,7 @@ let map_expr loop (e,p) =
 	and tparamdecl t =
 		{ tp_name = t.tp_name; tp_constraints = List.map ctype t.tp_constraints; tp_params = List.map tparamdecl t.tp_params }
 	and func f =
-		{	
+		{
 			f_params = List.map tparamdecl f.f_params;
 			f_args = List.map (fun (n,o,t,e) -> n,o,opt ctype t,opt loop e) f.f_args;
 			f_type = opt ctype f.f_type;
@@ -562,7 +570,7 @@ let reify in_macro =
 		match o with
 		| OpAdd -> op "OpAdd"
 		| OpMult -> op "OpMult"
-		| OpDiv -> op "OpDiv" 
+		| OpDiv -> op "OpDiv"
 		| OpSub -> op "OpSub"
 		| OpAssign -> op "OpAssign"
 		| OpEq -> op "OpEq"
@@ -636,7 +644,7 @@ let reify in_macro =
 			let fields = [
 				"name", to_string n p;
 				"opt", to_bool o p;
-				"type", to_opt to_ctype t p;					
+				"type", to_opt to_ctype t p;
 			] in
 			to_obj (match e with None -> fields | Some e -> fields @ ["value",to_expr e p]) p
 		in
@@ -657,7 +665,7 @@ let reify in_macro =
 		to_obj fields p
 	and to_cfield f p =
 		let p = f.cff_pos in
-		let to_access a p = 
+		let to_access a p =
 			let n = (match a with
 			| APublic -> "APublic"
 			| APrivate -> "APrivate"
@@ -687,7 +695,7 @@ let reify in_macro =
 		let fields = List.rev (List.fold_left (fun acc v -> match v with None -> acc | Some e -> e :: acc) [] fields) in
 		to_obj fields p
 	and to_meta m p =
-		to_array (fun (m,el,p) _ -> 
+		to_array (fun (m,el,p) _ ->
 			let fields = [
 				"name", to_string m p;
 				"params", to_expr_array el p;
@@ -705,10 +713,10 @@ let reify in_macro =
 			to_obj [("file",file);("min",pmin);("max",pmax)] p
 	and to_expr_array a p = match a with
 		| [EArray ((EConst(Ident("$")),_),e),p] -> e
-		| _ -> to_array to_expr a p		
+		| _ -> to_array to_expr a p
 	and to_expr e _ =
 		let p = snd e in
-		let expr n vl = 
+		let expr n vl =
 			let e = mk_enum "ExprDef" n vl p in
 			to_obj [("expr",e);("pos",to_pos p)] p
 		in
@@ -728,7 +736,7 @@ let reify in_macro =
 			expr "EField" [loop e; to_string s p]
 		| EParenthesis e ->
 			expr "EParenthesis" [loop e]
-		| EObjectDecl fl -> 
+		| EObjectDecl fl ->
 			expr "EObjectDecl" [to_array (fun (f,e) -> to_obj [("field",to_string f p);("expr",loop e)]) fl p]
 		| EArrayDecl el ->
 			expr "EArrayDecl" [to_expr_array el p]

genswf.ml

@@ -302,7 +302,15 @@ let build_class com c file =
 				match f.cff_kind with
 				| FVar (Some (CTPath { tpackage = []; tname = ("String" | "Int" | "UInt") as tname }),None) when List.mem AStatic f.cff_access ->
 					if !real_type = "" then real_type := tname else if !real_type <> tname then raise Exit;
-					(f.cff_name,None,[],[],pos) :: loop l
+					{
+						ec_name = f.cff_name;
+						ec_pos = pos;
+						ec_args = [];
+						ec_params = [];
+						ec_meta = [];
+						ec_doc = None;
+						ec_type = None;
+					} :: loop l
 				| FFun { f_args = [] } when f.cff_name = "new" -> loop l
 				| _ -> raise Exit
 		in

interp.ml

@@ -4003,20 +4003,22 @@ let rec encode_mtype t fields =
 		"isPrivate", VBool i.mt_private;
 		"meta", encode_meta i.mt_meta (fun m -> i.mt_meta <- m);
 		"doc", null enc_string i.mt_doc;
+		"params", encode_type_params i.mt_types;
 	] @ fields)
 
+and encode_type_params tl =
+	enc_array (List.map (fun (n,t) -> enc_obj ["name",enc_string n;"t",encode_type t]) tl)
+	
 and encode_tenum e =
 	encode_mtype (TEnumDecl e) [
 		"isExtern", VBool e.e_extern;
 		"exclude", VFunction (Fun0 (fun() -> e.e_extern <- true; VNull));
-		"params", enc_array (List.map (fun (n,t) -> enc_obj ["name",enc_string n;"t",encode_type t]) e.e_types);
 		"constructs", encode_pmap encode_efield e.e_constrs;
 		"names", enc_array (List.map enc_string e.e_names);
 	]
 
 and encode_tabstract a =
 	encode_mtype (TAbstractDecl a) [
-		"params", enc_array (List.map (fun (n,t) -> enc_obj ["name",enc_string n;"t",encode_type t]) a.a_types);
 	]
 
 and encode_efield f =
@@ -4027,6 +4029,7 @@ and encode_efield f =
 		"index", VInt f.ef_index;
 		"meta", encode_meta f.ef_meta (fun m -> f.ef_meta <- m);
 		"doc", null enc_string f.ef_doc;
+		"params", encode_type_params f.ef_params;
 	]
 
 and encode_cfield f =
@@ -4034,7 +4037,7 @@ and encode_cfield f =
 		"name", enc_string f.cf_name;
 		"type", (match f.cf_kind with Method _ -> encode_lazy_type f.cf_type | _ -> encode_type f.cf_type);
 		"isPublic", VBool f.cf_public;
-		"params", enc_array (List.map (fun (n,t) -> enc_obj ["name",enc_string n;"t",encode_type t]) f.cf_params);
+		"params", encode_type_params f.cf_params;
 		"meta", encode_meta f.cf_meta (fun m -> f.cf_meta <- m);
 		"expr", (VFunction (Fun0 (fun() -> ignore(follow f.cf_type); (match f.cf_expr with None -> VNull | Some e -> encode_texpr e))));
 		"kind", encode_field_kind f.cf_kind;
@@ -4088,7 +4091,6 @@ and encode_tclass c =
 		"kind", encode_class_kind c.cl_kind;
 		"isExtern", VBool c.cl_extern;
 		"exclude", VFunction (Fun0 (fun() -> c.cl_extern <- true; c.cl_init <- None; VNull));
-		"params", enc_array (List.map (fun (n,t) -> enc_obj ["name",enc_string n;"t",encode_type t]) c.cl_types);
 		"isInterface", VBool c.cl_interface;
 		"superClass", (match c.cl_super with
 			| None -> VNull
@@ -4105,7 +4107,6 @@ and encode_ttype t =
 	encode_mtype (TTypeDecl t) [
 		"isExtern", VBool false;
 		"exclude", VFunction (Fun0 (fun() -> VNull));
-		"params", enc_array (List.map (fun (n,t) -> enc_obj ["name",enc_string n;"t",encode_type t]) t.t_types);
 		"type", encode_type t.t_type;
 	]
 
@@ -4222,7 +4223,20 @@ let decode_type_def v =
 				| None -> raise Invalid_expr
 				| Some t -> n, opt, t
 			in
-			f.cff_name, f.cff_doc, f.cff_meta, (match f.cff_kind with FVar (None,None) -> [] | FFun f -> List.map loop f.f_args | _ -> raise Invalid_expr), f.cff_pos
+			let args, params, t = (match f.cff_kind with
+				| FVar (t,None) -> [], [], t
+				| FFun f -> List.map loop f.f_args, f.f_params, f.f_type
+				| _ -> raise Invalid_expr
+			) in
+			{
+				ec_name = f.cff_name;
+				ec_doc = f.cff_doc;
+				ec_meta = f.cff_meta;
+				ec_pos = f.cff_pos;
+				ec_args = args;
+				ec_params = params;
+				ec_type = t;
+			}
 		in
 		EEnum (mk (if isExtern then [EExtern] else []) (List.map conv fields))
 	| 1, [] ->

main.ml

@@ -350,7 +350,10 @@ let run_command ctx cmd =
 			end
 		| s :: _ ->
 			let n = Unix.read s tmp 0 (String.length tmp) in
-			Buffer.add_substring (if s == iout then bout else berr) tmp 0 n;
+			if s == iout && n > 0 then
+				ctx.com.print (String.sub tmp 0 n)
+			else
+				Buffer.add_substring (if s == iout then bout else berr) tmp 0 n;
 			loop (if n = 0 then List.filter ((!=) s) ins else ins)
 	in
 	(try loop [iout;ierr] with Unix.Unix_error _ -> ());
@@ -661,14 +664,6 @@ and do_connect host port args =
 	(try Unix.connect sock (Unix.ADDR_INET (Unix.inet_addr_of_string host,port)) with _ -> failwith ("Couldn't connect on " ^ host ^ ":" ^ string_of_int port));
 	let args = ("--cwd " ^ Unix.getcwd()) :: args in
 	ssend sock (String.concat "" (List.map (fun a -> a ^ "\n") args) ^ "\000");
-	let buf = Buffer.create 0 in
-	let tmp = String.create 100 in
-	let rec loop() =
-		let b = Unix.recv sock tmp 0 100 [] in
-		Buffer.add_substring buf tmp 0 b;
-		if b > 0 then loop()
-	in
-	loop();
 	let has_error = ref false in
 	let rec print line =
 		match (if line = "" then '\x00' else line.[0]) with
@@ -679,9 +674,28 @@ and do_connect host port args =
 		| _ ->
 			prerr_endline line;
 	in
-	let lines = ExtString.String.nsplit (Buffer.contents buf) "\n" in
-	let lines = (match List.rev lines with "" :: l -> List.rev l | _ -> lines) in
-	List.iter print lines;
+	let buf = Buffer.create 0 in
+	let process() =
+		let lines = ExtString.String.nsplit (Buffer.contents buf) "\n" in
+		(* the last line ends with \n *)
+		let lines = (match List.rev lines with "" :: l -> List.rev l | _ -> lines) in
+		List.iter print lines;
+	in
+	let tmp = String.create 1024 in
+	let rec loop() =
+		let b = Unix.recv sock tmp 0 1024 [] in
+		Buffer.add_substring buf tmp 0 b;
+		if b > 0 then begin
+			prerr_endline (string_of_int (int_of_char (String.get tmp (b - 1))));
+			if String.get tmp (b - 1) = '\n' then begin
+				process();
+				Buffer.reset buf;
+			end;
+			loop();
+		end
+	in
+	loop();
+	process();
 	if !has_error then exit 1
 
 and init ctx =

parser.ml

@@ -499,11 +499,28 @@ and parse_enum s =
 	doc := None;
 	let meta = parse_meta s in
 	match s with parser
-	| [< name, p1 = any_enum_ident; doc = get_doc; s >] ->
-		match s with parser
-		| [< '(POpen,_); l = psep Comma parse_enum_param; '(PClose,_); p = semicolon; >] -> (name,doc,meta,l,punion p1 p)
-		| [< '(Semicolon,p) >] -> (name,doc,meta,[],punion p1 p)
-		| [< >] -> serror()
+	| [< name, p1 = any_enum_ident; doc = get_doc; params = parse_constraint_params; s >] ->
+		let args = (match s with parser
+		| [< '(POpen,_); l = psep Comma parse_enum_param; '(PClose,_) >] -> l
+		| [< >] -> []
+		) in
+		let t = (match s with parser
+		| [< '(DblDot,_); t = parse_complex_type >] -> Some t
+		| [< >] -> None
+		) in
+		let p2 = (match s with parser
+			| [< p = semicolon >] -> p
+			| [< >] -> serror()
+		) in
+		{
+			ec_name = name;
+			ec_doc = doc;
+			ec_meta = meta;
+			ec_args = args;
+			ec_params = params;
+			ec_type = t;
+			ec_pos = punion p1 p2;
+		}
 
 and parse_enum_param = parser
 	| [< '(Question,_); name, _ = ident; '(DblDot,_); t = parse_complex_type >] -> (name,true,t)

std/haxe/macro/Type.hx

@@ -98,6 +98,7 @@ typedef EnumField = {
 	var meta : MetaAccess;
 	var index : Int;
 	var doc : Null<String>;
+	var params : Array<{ name : String, t : Type }>;
 }
 
 typedef EnumType = {> BaseType,

type.ml

@@ -199,6 +199,7 @@ and tenum_field = {
 	ef_pos : Ast.pos;
 	ef_doc : Ast.documentation;
 	ef_index : int;
+	ef_params : type_params;
 	mutable ef_meta : metadata;
 }
 

typeload.ml

@@ -1683,16 +1683,16 @@ let init_module_type ctx context_init do_init (decl,p) =
 			e.e_meta <- e.e_meta @ hcl.tp_meta);
 		let constructs = ref d.d_data in
 		let get_constructs() =
-			List.map (fun (c,doc,meta,pl,p) ->
+			List.map (fun c ->
 				{
-					cff_name = c;
-					cff_doc = doc;
-					cff_meta = meta;
-					cff_pos = p;
+					cff_name = c.ec_name;
+					cff_doc = c.ec_doc;
+					cff_meta = c.ec_meta;
+					cff_pos = c.ec_pos;
 					cff_access = [];
-					cff_kind = (match pl with
-						| [] -> FVar (None,None)
-						| _ -> FFun { f_params = []; f_type = None; f_expr = None; f_args = List.map (fun (n,o,t) -> n,o,Some t,None) pl });
+					cff_kind = (match c.ec_args, c.ec_params with
+						| [], [] -> FVar (c.ec_type,None)
+						| _ -> FFun { f_params = c.ec_params; f_type = c.ec_type; f_expr = None; f_args = List.map (fun (n,o,t) -> n,o,Some t,None) c.ec_args });
 				}
 			) (!constructs)
 		in
@@ -1700,39 +1700,68 @@ let init_module_type ctx context_init do_init (decl,p) =
 			match e with
 			| EVars [_,Some (CTAnonymous fields),None] ->
 				constructs := List.map (fun f ->
-					(f.cff_name,f.cff_doc,f.cff_meta,(match f.cff_kind with
-					| FVar (None,None) -> []
-					| FFun { f_params = []; f_type = None; f_expr = (None|Some (EBlock [],_)); f_args = pl } -> List.map (fun (n,o,t,_) -> match t with None -> error "Missing function parameter type" f.cff_pos | Some t -> n,o,t) pl
-					| _ -> error "Invalid enum constructor in @:build result" p
-					),f.cff_pos)
+					let args, params, t = (match f.cff_kind with
+					| FVar (t,None) -> [], [], t
+					| FFun { f_params = pl; f_type = t; f_expr = (None|Some (EBlock [],_)); f_args = al } ->
+						let al = List.map (fun (n,o,t,_) -> match t with None -> error "Missing function parameter type" f.cff_pos | Some t -> n,o,t) al in
+						al, pl, t
+					| _ ->
+						error "Invalid enum constructor in @:build result" p
+					) in
+					{
+						ec_name = f.cff_name;
+						ec_doc = f.cff_doc;
+						ec_meta = f.cff_meta;
+						ec_pos = f.cff_pos;
+						ec_args = args;
+						ec_params = params;
+						ec_type = t;
+					}
 				) fields
 			| _ -> error "Enum build macro must return a single variable with anonymous object fields" p
 		);
 		let et = TEnum (e,List.map snd e.e_types) in
 		let names = ref [] in
 		let index = ref 0 in
-		List.iter (fun (c,doc,meta,t,p) ->
-			let t = (match t with
-				| [] -> et
+		List.iter (fun c ->
+			let p = c.ec_pos in
+			let params = ref [] in
+			params := List.map (fun tp -> type_type_params ctx ([],c.ec_name) (fun() -> !params) c.ec_pos tp) c.ec_params;
+			let params = !params in
+			let ctx = { ctx with type_params = params @ ctx.type_params } in
+			let rt = (match c.ec_type with
+				| None -> et
+				| Some t ->
+					let t = load_complex_type ctx p t in
+					(match follow t with
+					| TEnum (te,_) when te == e ->
+						()
+					| _ ->
+						error "Explicit enum type must be of the same enum type" p);
+					t
+			) in
+			let t = (match c.ec_args with
+				| [] -> rt
 				| l ->
 					let pnames = ref PMap.empty in
 					TFun (List.map (fun (s,opt,t) ->
-						if PMap.mem s (!pnames) then error ("Duplicate parameter '" ^ s ^ "' in enum constructor " ^ c) p;
+						if PMap.mem s (!pnames) then error ("Duplicate parameter '" ^ s ^ "' in enum constructor " ^ c.ec_name) p;
 						pnames := PMap.add s () (!pnames);
 						s, opt, load_type_opt ~opt ctx p (Some t)
-					) l, et)
+					) l, rt)
 			) in
-			if PMap.mem c e.e_constrs then error ("Duplicate constructor " ^ c) p;
-			e.e_constrs <- PMap.add c {
-				ef_name = c;
+			if PMap.mem c.ec_name e.e_constrs then error ("Duplicate constructor " ^ c.ec_name) p;
+			e.e_constrs <- PMap.add c.ec_name {
+				ef_name = c.ec_name;
 				ef_type = t;
 				ef_pos = p;
-				ef_doc = doc;
+				ef_doc = c.ec_doc;
 				ef_index = !index;
-				ef_meta = meta;
+				ef_params = params;
+				ef_meta = c.ec_meta;
 			} e.e_constrs;
 			incr index;
-			names := c :: !names;
+			names := c.ec_name :: !names;
 		) (!constructs);
 		e.e_names <- List.rev !names;
 		e.e_extern <- e.e_extern || e.e_names = [];

typer.ml

@@ -839,7 +839,7 @@ let rec type_ident_raise ?(imported_enums=true) ctx i p mode =
 				| TEnumDecl e ->
 					try
 						let ef = PMap.find i e.e_constrs in
-						mk (TEnumField (e,i)) (monomorphs e.e_types ef.ef_type) p
+						mk (TEnumField (e,i)) (monomorphs ef.ef_params (monomorphs e.e_types ef.ef_type)) p
 					with
 						Not_found -> loop l
 		in
@@ -1444,7 +1444,7 @@ and type_switch ctx e cases def need_val with_type p =
 				| [None] -> List.map (fun _ -> None) l
 				| _ -> error ("This constructor requires " ^ string_of_int (List.length l) ^ " arguments") p
 			) in
-			Some (List.map2 (fun p (_,_,t) -> match p with None -> None | Some p -> Some (p, apply_params en.e_types params t)) pl l)
+			Some (List.map2 (fun p (_,_,t) -> match p with None -> None | Some p -> Some (p, monomorphs cst.ef_params (apply_params en.e_types params t))) pl l)
 		| TEnum _ ->
 			if pl <> [] then error "This constructor does not require any argument" p;
 			None