refactor create_module_type

src/typing/typeloadModule.ml

@@ -62,7 +62,17 @@ module ModuleLevel = struct
 	*)
 	let create_module_types ctx_m m tdecls loadp =
 		let com = ctx_m.com in
-		let decls = ref [] in
+		let module_types = DynArray.create () in
+		let declarations = DynArray.create () in
+		let add_declaration decl tdecl =
+			DynArray.add declarations (decl,tdecl);
+			match tdecl with
+				| None ->
+					()
+				| Some mt ->
+					ctx_m.com.module_lut#add_module_type m mt;
+					DynArray.add module_types mt;
+		in
 		let statics = ref [] in
 		let check_name name meta also_statics p =
 			DeprecationCheck.check_is com ctx_m.m.curmod meta [] name meta p;
@@ -70,9 +80,9 @@ module ModuleLevel = struct
 				display_error com ("Name " ^ name ^ " is already defined in this module") p;
 				raise_typing_error ~depth:1 (compl_msg "Previous declaration here") prev_pos;
 			in
-			List.iter (fun (t2,(_,p2)) ->
+			DynArray.iter (fun t2 ->
 				if snd (t_path t2) = name then error (t_infos t2).mt_name_pos
-			) !decls;
+			) module_types;
 			if also_statics then
 				List.iter (fun (d,_) ->
 					if fst d.d_name = name then error (snd d.d_name)
@@ -83,155 +93,149 @@ module ModuleLevel = struct
 			if priv then (fst m.m_path @ ["_" ^ snd m.m_path], name) else (fst m.m_path, name)
 		in
 		let has_declaration = ref false in
-		let rec make_decl acc decl =
+		let check_type_name type_name meta p =
+			let module_name = snd m.m_path in
+			if type_name <> module_name && not (Meta.has Meta.Native meta) then Naming.check_uppercase_identifier_name ctx_m.com type_name "type" p;
+		in
+		let handle_class_decl d p =
+			let name = fst d.d_name in
+			has_declaration := true;
+			let priv = List.mem HPrivate d.d_flags in
+			let path = make_path name priv d.d_meta (snd d.d_name) in
+			let c = mk_class m path p (pos d.d_name) in
+			(* we shouldn't load any other type until we propertly set cl_build *)
+			c.cl_build <- (fun() -> raise_typing_error (s_type_path c.cl_path ^ " is not ready to be accessed, separate your type declarations in several files") p);
+			c.cl_module <- m;
+			c.cl_private <- priv;
+			c.cl_doc <- d.d_doc;
+			c.cl_meta <- d.d_meta;
+			if List.mem HAbstract d.d_flags then add_class_flag c CAbstract;
+			List.iter (function
+				| HExtern -> add_class_flag c CExtern
+				| HInterface -> add_class_flag c CInterface
+				| HFinal -> add_class_flag c CFinal
+				| _ -> ()
+			) d.d_flags;
+			if not (has_class_flag c CExtern) then check_type_name name d.d_meta p;
+			if has_class_flag c CAbstract then begin
+				if has_class_flag c CInterface then display_error com "An interface may not be abstract" c.cl_name_pos;
+				if has_class_flag c CFinal then display_error com "An abstract class may not be final" c.cl_name_pos;
+			end;
+			c
+		in
+		let make_decl decl =
 			let p = snd decl in
-			let check_type_name type_name meta =
-				let module_name = snd m.m_path in
-				if type_name <> module_name && not (Meta.has Meta.Native meta) then Naming.check_uppercase_identifier_name ctx_m.com type_name "type" p;
-			in
-			let acc = (match fst decl with
-			| EImport _ | EUsing _ ->
-				if !has_declaration then raise_typing_error "import and using may not appear after a declaration" p;
-				acc
-			| EStatic d ->
-				check_name (fst d.d_name) d.d_meta false (snd d.d_name);
-				has_declaration := true;
-				statics := (d,p) :: !statics;
-				acc;
-			| EClass d ->
-				let name = fst d.d_name in
-				has_declaration := true;
-				let priv = List.mem HPrivate d.d_flags in
-				let path = make_path name priv d.d_meta (snd d.d_name) in
-				let c = mk_class m path p (pos d.d_name) in
-				(* we shouldn't load any other type until we propertly set cl_build *)
-				c.cl_build <- (fun() -> raise_typing_error (s_type_path c.cl_path ^ " is not ready to be accessed, separate your type declarations in several files") p);
-				c.cl_module <- m;
-				c.cl_private <- priv;
-				c.cl_doc <- d.d_doc;
-				c.cl_meta <- d.d_meta;
-				if List.mem HAbstract d.d_flags then add_class_flag c CAbstract;
-				List.iter (function
-					| HExtern -> add_class_flag c CExtern
-					| HInterface -> add_class_flag c CInterface
-					| HFinal -> add_class_flag c CFinal
-					| _ -> ()
-				) d.d_flags;
-				if not (has_class_flag c CExtern) then check_type_name name d.d_meta;
-				if has_class_flag c CAbstract then begin
-					if has_class_flag c CInterface then display_error com "An interface may not be abstract" c.cl_name_pos;
-					if has_class_flag c CFinal then display_error com "An abstract class may not be final" c.cl_name_pos;
-				end;
-				decls := (TClassDecl c, decl) :: !decls;
-				acc
-			| EEnum d ->
-				let name = fst d.d_name in
-				has_declaration := true;
-				let priv = List.mem EPrivate d.d_flags in
-				let path = make_path name priv d.d_meta p in
-				if Meta.has (Meta.Custom ":fakeEnum") d.d_meta then raise_typing_error "@:fakeEnum enums is no longer supported in Haxe 4, use extern enum abstract instead" p;
-				let e = {
-					(mk_enum m path p (pos d.d_name)) with
-					e_doc = d.d_doc;
-					e_meta = d.d_meta;
-					e_private = priv;
-					e_extern = List.mem EExtern d.d_flags;
-				} in
-				if not e.e_extern then check_type_name name d.d_meta;
-				decls := (TEnumDecl e, decl) :: !decls;
-				acc
-			| ETypedef d ->
-				let name = fst d.d_name in
-				check_type_name name d.d_meta;
-				has_declaration := true;
-				let priv = List.mem EPrivate d.d_flags in
-				let path = make_path name priv d.d_meta p in
-				let t = {(mk_typedef m path p (pos d.d_name) (mk_mono())) with
-					t_doc = d.d_doc;
-					t_private = priv;
-					t_meta = d.d_meta;
-				} in
-				(* failsafe in case the typedef is not initialized (see #3933) *)
-				delay ctx_m.g PBuildModule (fun () ->
-					match t.t_type with
-					| TMono r -> (match r.tm_type with None -> Monomorph.bind r com.basic.tvoid | _ -> ())
-					| _ -> ()
-				);
-				decls := (TTypeDecl t, decl) :: !decls;
-				acc
-			| EAbstract d ->
-				let name = fst d.d_name in
-				check_type_name name d.d_meta;
-				let priv = List.mem AbPrivate d.d_flags in
-				let path = make_path name priv d.d_meta p in
-				let p_enum_meta = Meta.maybe_get_pos Meta.Enum d.d_meta in
-				let a = {
-					a_path = path;
-					a_private = priv;
-					a_module = m;
-					a_pos = p;
-					a_name_pos = pos d.d_name;
-					a_doc = d.d_doc;
-					a_params = [];
-					a_using = [];
-					a_restore = (fun () -> ());
-					a_meta = d.d_meta;
-					a_from = [];
-					a_to = [];
-					a_from_field = [];
-					a_to_field = [];
-					a_ops = [];
-					a_unops = [];
-					a_impl = None;
-					a_array = [];
-					a_this = mk_mono();
-					a_read = None;
-					a_write = None;
-					a_call = None;
-					a_enum = List.mem AbEnum d.d_flags || p_enum_meta <> None;
-				} in
-				begin match p_enum_meta with
-					| None when a.a_enum -> a.a_meta <- (Meta.Enum,[],null_pos) :: a.a_meta; (* HAXE5: remove *)
-					| None -> ()
-					| Some p ->
-						let options = Warning.from_meta d.d_meta in
-						module_warning com ctx_m.m.curmod WDeprecatedEnumAbstract options "`@:enum abstract` is deprecated in favor of `enum abstract`" p
-				end;
-				decls := (TAbstractDecl a, decl) :: !decls;
-				match d.d_data with
-				| [] when Meta.has Meta.CoreType a.a_meta ->
-					a.a_this <- t_dynamic;
-					acc
-				| fields ->
-					let a_t =
-						let params = List.map (fun t -> TPType (make_ptp_th (mk_type_path ([],fst t.tp_name)) null_pos)) d.d_params in
-						make_ptp_ct_null (mk_type_path ~params ([],fst d.d_name)),null_pos
-					in
-					let rec loop = function
-						| [] -> a_t
-						| AbOver t :: _ -> t
-						| _ :: l -> loop l
-					in
-					let this_t = loop d.d_flags in
-					let fields = List.map (TypeloadFields.transform_abstract_field com this_t a_t a) fields in
-					let meta = ref [] in
-					if has_meta Meta.Dce a.a_meta then meta := (Meta.Dce,[],null_pos) :: !meta;
-					let acc = make_decl acc (EClass { d_name = (fst d.d_name) ^ "_Impl_",snd d.d_name; d_flags = [HPrivate]; d_data = fields; d_doc = None; d_params = []; d_meta = !meta },p) in
-					(match !decls with
-					| (TClassDecl c,_) :: _ ->
+			match fst decl with
+				| EImport _ | EUsing _ ->
+					if !has_declaration then raise_typing_error "import and using may not appear after a declaration" p;
+					add_declaration decl None
+				| EStatic d ->
+					check_name (fst d.d_name) d.d_meta false (snd d.d_name);
+					has_declaration := true;
+					statics := (d,p) :: !statics;
+				| EClass d ->
+					add_declaration decl (Some (TClassDecl (handle_class_decl d p)))
+				| EEnum d ->
+					let name = fst d.d_name in
+					has_declaration := true;
+					let priv = List.mem EPrivate d.d_flags in
+					let path = make_path name priv d.d_meta p in
+					if Meta.has (Meta.Custom ":fakeEnum") d.d_meta then raise_typing_error "@:fakeEnum enums is no longer supported in Haxe 4, use extern enum abstract instead" p;
+					let e = {
+						(mk_enum m path p (pos d.d_name)) with
+						e_doc = d.d_doc;
+						e_meta = d.d_meta;
+						e_private = priv;
+						e_extern = List.mem EExtern d.d_flags;
+					} in
+					if not e.e_extern then check_type_name name d.d_meta p;
+					add_declaration decl (Some (TEnumDecl e))
+				| ETypedef d ->
+					let name = fst d.d_name in
+					check_type_name name d.d_meta p;
+					has_declaration := true;
+					let priv = List.mem EPrivate d.d_flags in
+					let path = make_path name priv d.d_meta p in
+					let t = {(mk_typedef m path p (pos d.d_name) (mk_mono())) with
+						t_doc = d.d_doc;
+						t_private = priv;
+						t_meta = d.d_meta;
+					} in
+					(* failsafe in case the typedef is not initialized (see #3933) *)
+					delay ctx_m.g PBuildModule (fun () ->
+						match t.t_type with
+						| TMono r -> (match r.tm_type with None -> Monomorph.bind r com.basic.tvoid | _ -> ())
+						| _ -> ()
+					);
+					add_declaration decl (Some (TTypeDecl t))
+				| EAbstract d ->
+					let name = fst d.d_name in
+					check_type_name name d.d_meta p;
+					let priv = List.mem AbPrivate d.d_flags in
+					let path = make_path name priv d.d_meta p in
+					let p_enum_meta = Meta.maybe_get_pos Meta.Enum d.d_meta in
+					let a = {
+						a_path = path;
+						a_private = priv;
+						a_module = m;
+						a_pos = p;
+						a_name_pos = pos d.d_name;
+						a_doc = d.d_doc;
+						a_params = [];
+						a_using = [];
+						a_restore = (fun () -> ());
+						a_meta = d.d_meta;
+						a_from = [];
+						a_to = [];
+						a_from_field = [];
+						a_to_field = [];
+						a_ops = [];
+						a_unops = [];
+						a_impl = None;
+						a_array = [];
+						a_this = mk_mono();
+						a_read = None;
+						a_write = None;
+						a_call = None;
+						a_enum = List.mem AbEnum d.d_flags || p_enum_meta <> None;
+					} in
+					begin match p_enum_meta with
+						| None when a.a_enum -> a.a_meta <- (Meta.Enum,[],null_pos) :: a.a_meta; (* HAXE5: remove *)
+						| None -> ()
+						| Some p ->
+							let options = Warning.from_meta d.d_meta in
+							module_warning com ctx_m.m.curmod WDeprecatedEnumAbstract options "`@:enum abstract` is deprecated in favor of `enum abstract`" p
+					end;
+					add_declaration decl (Some (TAbstractDecl a));
+					begin match d.d_data with
+					| [] when Meta.has Meta.CoreType a.a_meta ->
+						a.a_this <- t_dynamic;
+					| fields ->
+						let a_t =
+							let params = List.map (fun t -> TPType (make_ptp_th (mk_type_path ([],fst t.tp_name)) null_pos)) d.d_params in
+							make_ptp_ct_null (mk_type_path ~params ([],fst d.d_name)),null_pos
+						in
+						let rec loop = function
+							| [] -> a_t
+							| AbOver t :: _ -> t
+							| _ :: l -> loop l
+						in
+						let this_t = loop d.d_flags in
+						let fields = List.map (TypeloadFields.transform_abstract_field com this_t a_t a) fields in
+						let meta = ref [] in
+						if has_meta Meta.Dce a.a_meta then meta := (Meta.Dce,[],null_pos) :: !meta;
+						let c_decl = { d_name = (fst d.d_name) ^ "_Impl_",snd d.d_name; d_flags = [HPrivate]; d_data = fields; d_doc = None; d_params = []; d_meta = !meta } in
+						let c = handle_class_decl c_decl p in
 						a.a_impl <- Some c;
 						c.cl_kind <- KAbstractImpl a;
 						add_class_flag c CFinal;
-					| _ -> die "" __LOC__);
-					acc
-			) in
-			decl :: acc
+						add_declaration (EClass c_decl,p) (Some (TClassDecl c));
+					end;
 		in
-		let tdecls = List.fold_left make_decl [] tdecls in
-		let tdecls =
-			match !statics with
+		List.iter make_decl tdecls;
+		begin match !statics with
 			| [] ->
-				tdecls
+				()
 			| statics ->
 				let first_pos = ref null_pos in
 				let fields = List.map (fun (d,p) ->
@@ -239,7 +243,7 @@ module ModuleLevel = struct
 					field_of_static_definition d p;
 				) statics in
 				let p = let p = !first_pos in { p with pmax = p.pmin } in
-				let c = EClass {
+				let c_def = {
 					d_name = (snd m.m_path) ^ "_Fields_", null_pos;
 					d_flags = [HPrivate];
 					d_data = List.rev fields;
@@ -247,19 +251,18 @@ module ModuleLevel = struct
 					d_params = [];
 					d_meta = []
 				} in
-				let tdecls = make_decl tdecls (c,p) in
-				(match !decls with
-				| (TClassDecl c,_) :: _ ->
-					assert (m.m_statics = None);
-					m.m_statics <- Some c;
-					c.cl_kind <- KModuleFields m;
-					add_class_flag c CFinal;
-				| _ -> assert false);
-				tdecls
-
-		in
-		let decls = List.rev !decls in
-		decls, List.rev tdecls
+				let c = handle_class_decl c_def p in
+				assert (m.m_statics = None);
+				m.m_statics <- Some c;
+				c.cl_kind <- KModuleFields m;
+				add_class_flag c CFinal;
+				add_declaration (EClass c_def,p) (Some (TClassDecl c));
+		end;
+		(* During the initial module_lut#add in type_module, m has no m_types yet by design.
+		   We manually add them here. This and module_lut#add itself should be the only places
+		   in the compiler that call add_module_type. *)
+		m.m_types <- m.m_types @ (DynArray.to_list module_types);
+		DynArray.to_list declarations
 
 	let handle_import_hx com g m decls p =
 		let path_split = match List.rev (Path.get_path_parts (Path.UniqueKey.lazy_path m.m_extra.m_file)) with
@@ -312,7 +315,7 @@ module ModuleLevel = struct
 		 Constraints are handled lazily (no other type is loaded) because they might be recursive anyway *)
 		 List.iter (fun d ->
 			match d with
-			| (TClassDecl c, (EClass d, p)) ->
+			| (EClass d, p),Some (TClassDecl c) ->
 				c.cl_params <- type_type_params ctx_m TPHType c.cl_path p d.d_params;
 				if Meta.has Meta.Generic c.cl_meta && c.cl_params <> [] then c.cl_kind <- KGeneric;
 				if Meta.has Meta.GenericBuild c.cl_meta then begin
@@ -320,12 +323,14 @@ module ModuleLevel = struct
 					c.cl_kind <- KGenericBuild d.d_data;
 				end;
 				if c.cl_path = (["haxe";"macro"],"MacroType") then c.cl_kind <- KMacroType;
-			| (TEnumDecl e, (EEnum d, p)) ->
+			| ((EEnum d, p),Some (TEnumDecl e)) ->
 				e.e_params <- type_type_params ctx_m TPHType e.e_path p d.d_params;
-			| (TTypeDecl t, (ETypedef d, p)) ->
+			| ((ETypedef d, p),Some (TTypeDecl t)) ->
 				t.t_params <- type_type_params ctx_m TPHType t.t_path p d.d_params;
-			| (TAbstractDecl a, (EAbstract d, p)) ->
+			| ((EAbstract d, p),Some (TAbstractDecl a)) ->
 				a.a_params <- type_type_params ctx_m TPHType a.a_path p d.d_params;
+			| (((EImport _ | EUsing _),_),None) ->
+				()
 			| _ ->
 				die "" __LOC__
 		) decls
@@ -641,11 +646,8 @@ module TypeLevel = struct
 		since they have not been setup. We also build a list that will be evaluated the first time we evaluate
 		an expression into the context
 	*)
-	let init_module_type ctx_m (decl,p) =
+	let init_module_type ctx_m ((decl,p),tdecl) =
 		let com = ctx_m.com in
-		let get_type name =
-			try List.find (fun t -> snd (t_infos t).mt_path = name) ctx_m.m.curmod.m_types with Not_found -> die "" __LOC__
-		in
 		let check_path_display path p =
 			if DisplayPosition.display_position#is_in_file (com.file_keys#get p.pfile) then DisplayPath.handle_path_display ctx_m path p
 			in
@@ -662,16 +664,16 @@ module TypeLevel = struct
 			check_path_display path p;
 			ImportHandling.init_using ctx_m path p
 		| EClass d ->
-			let c = (match get_type (fst d.d_name) with TClassDecl c -> c | _ -> die "" __LOC__) in
+			let c = (match tdecl with Some (TClassDecl c) -> c | _ -> die "" __LOC__) in
 			init_class ctx_m c d p
 		| EEnum d ->
-			let e = (match get_type (fst d.d_name) with TEnumDecl e -> e | _ -> die "" __LOC__) in
+			let e = (match tdecl with Some (TEnumDecl e) -> e | _ -> die "" __LOC__) in
 			init_enum ctx_m e d p
 		| ETypedef d ->
-			let t = (match get_type (fst d.d_name) with TTypeDecl t -> t | _ -> die "" __LOC__) in
+			let t = (match tdecl with Some (TTypeDecl t) -> t | _ -> die "" __LOC__) in
 			init_typedef ctx_m t d p
 		| EAbstract d ->
-			let a = (match get_type (fst d.d_name) with TAbstractDecl a -> a | _ -> die "" __LOC__) in
+			let a = (match tdecl with Some (TAbstractDecl a) -> a | _ -> die "" __LOC__) in
 			init_abstract ctx_m a d p
 		| EStatic _ ->
 			(* nothing to do here as module fields are collected into a special EClass *)
@@ -698,13 +700,7 @@ let make_curmod com g m =
 *)
 let type_types_into_module com g m tdecls p =
 	let ctx_m = TyperManager.clone_for_module g.root_typer (make_curmod com g m) in
-	let decls,tdecls = ModuleLevel.create_module_types ctx_m m tdecls p in
-	let types = List.map fst decls in
-	(* During the initial module_lut#add in type_module, m has no m_types yet by design.
-	   We manually add them here. This and module_lut#add itself should be the only places
-	   in the compiler that call add_module_type. *)
-	List.iter (fun mt -> ctx_m.com.module_lut#add_module_type m mt) types;
-	m.m_types <- m.m_types @ types;
+	let decls = ModuleLevel.create_module_types ctx_m m tdecls p in
 	(* define the per-module context for the next pass *)
 	if ctx_m.g.std_types != null_module then begin
 		add_dependency m ctx_m.g.std_types;
@@ -713,7 +709,7 @@ let type_types_into_module com g m tdecls p =
 	end;
 	ModuleLevel.init_type_params ctx_m decls;
 	(* setup module types *)
-	List.iter (TypeLevel.init_module_type ctx_m) tdecls;
+	List.iter (TypeLevel.init_module_type ctx_m) decls;
 	(* Make sure that we actually init the context at some point (issue #9012) *)
 	delay ctx_m.g PConnectField (fun () -> ctx_m.m.import_resolution#resolve_lazies);
 	ctx_m