add --display File.hx@pos@statistics

currently lists implementers and sub classes per-file

src/display/display.ml

@@ -11,6 +11,7 @@ type display_field_kind =
 	| FKPackage
 
 exception Diagnostics of string
+exception Statistics of string
 exception ModuleSymbols of string
 exception DisplaySignatures of (t * documentation) list
 exception DisplayType of t * pos
@@ -520,4 +521,88 @@ module Diagnostics = struct
 end
 
 let maybe_mark_import_position ctx p =
-	if Diagnostics.is_diagnostics_run ctx then mark_import_position ctx.com p
+	if Diagnostics.is_diagnostics_run ctx then mark_import_position ctx.com p
+
+
+module Statistics = struct
+
+	type class_relation = (path,(tclass * tclass DynArray.t)) Hashtbl.t
+
+	type file_statistics = {
+		implementer : class_relation;
+		subclasses : class_relation;
+	}
+
+	type statistics = {
+		files : (string,file_statistics) Hashtbl.t;
+	}
+
+	let print_statistics tctx =
+		let statistics = {
+			files = Hashtbl.create 0
+		} in
+		let get_file_statistics file =
+			let key = get_real_path file in
+			try
+				Hashtbl.find statistics.files key
+			with Not_found ->
+				let file_statistics = {
+					implementer = Hashtbl.create 0;
+					subclasses = Hashtbl.create 0;
+				} in
+				Hashtbl.add statistics.files key file_statistics;
+				file_statistics
+		in
+		let add map ci c =
+			let l = try
+				snd (Hashtbl.find map ci.cl_path)
+			with Not_found ->
+				let l = DynArray.create () in
+				Hashtbl.add map ci.cl_path (ci,l);
+				l
+			in
+			DynArray.add l c
+		in
+		List.iter (function
+			| TClassDecl c ->
+				List.iter (fun (ci,_) ->
+					if is_display_file ci.cl_pos.pfile then add (get_file_statistics ci.cl_pos.pfile).implementer ci c
+				) c.cl_implements;
+				begin match c.cl_super with
+					| Some (cs,_) when is_display_file cs.cl_pos.pfile -> add (get_file_statistics cs.cl_pos.pfile).subclasses cs c
+					| _ -> ()
+				end
+			| _ -> ()
+		) tctx.com.types;
+		let relation_list l =
+			Hashtbl.fold (fun _ (ci,l) acc ->
+				let jl = List.map (fun c ->
+					JObject [
+						"range",pos_to_json_range c.cl_pos;
+						"file",JString (get_real_path c.cl_pos.pfile)
+					]
+				) (DynArray.to_list l) in
+				(JObject [
+					"range",pos_to_json_range ci.cl_pos;
+					"classes",JArray jl
+				]) :: acc
+			) l []
+		in
+		let ja = Hashtbl.fold (fun file statistics acc ->
+			if Hashtbl.length statistics.implementer = 0 && Hashtbl.length statistics.subclasses = 0 then
+				acc
+			else begin
+				let js = JObject [
+					"implementer",JArray (relation_list statistics.implementer);
+					"subclasses",JArray (relation_list statistics.subclasses);
+				] in
+				(JObject [
+					"file",JString file;
+					"statistics",js
+				]) :: acc
+			end
+		) statistics.files [] in
+		let b = Buffer.create 0 in
+		write_json (Buffer.add_string b) (JArray ja);
+		Buffer.contents b
+end

src/main.ml

@@ -1302,6 +1302,9 @@ try
 					| "diagnostics" ->
 						Common.define com Define.NoCOpt;
 						DMDiagnostics false;
+					| "statistics" ->
+						Common.define com Define.NoCOpt;
+						DMStatistics
 					| "" ->
 						DMDefault
 					| _ ->
@@ -1467,7 +1470,7 @@ try
 	process ctx.com.args;
 	process_libs();
 	begin match com.display with
-	| DMNone | DMDiagnostics true ->
+	| DMNone | DMDiagnostics true | DMStatistics ->
 		()
 	| _ ->
 		com.warning <- if com.display = DMDiagnostics false then (fun s p -> add_diagnostics_message com s p DiagnosticsSeverity.Warning) else message ctx;
@@ -1604,7 +1607,7 @@ try
 		t();
 		if ctx.has_error then raise Abort;
 		begin match ctx.com.display with
-			| DMNone | DMUsage | DMDiagnostics true ->
+			| DMNone | DMUsage | DMDiagnostics true | DMStatistics ->
 				()
 			| _ ->
 				if ctx.has_next then raise Abort;
@@ -1620,6 +1623,7 @@ try
 			| DMDiagnostics true ->
 				Display.Diagnostics.prepare com;
 				raise (Display.Diagnostics (Display.Diagnostics.print_diagnostics tctx))
+			| DMStatistics -> raise (Display.Statistics (Display.Statistics.print_statistics tctx))
 			| _ -> ()
 		end;
 		Filters.run com tctx main;
@@ -1868,7 +1872,7 @@ with
 				raise (Completion c)
 			| _ ->
 				error ctx ("Could not load module " ^ (Ast.s_type_path (p,c))) Ast.null_pos)
-	| Display.ModuleSymbols s | Display.Diagnostics s ->
+	| Display.ModuleSymbols s | Display.Diagnostics s | Display.Statistics s ->
 		raise (Completion s)
 	| Interp.Sys_exit i ->
 		ctx.flush();

src/typing/common.ml

@@ -101,6 +101,7 @@ type display_mode =
 	| DMType
 	| DMModuleSymbols
 	| DMDiagnostics of bool (* true = global, false = only in display file *)
+	| DMStatistics
 
 type compiler_callback = {
 	mutable after_typing : (module_type list -> unit) list;

src/typing/typeload.ml

@@ -2125,7 +2125,7 @@ module ClassInitializer = struct
 			end
 		in
 		begin match ctx.com.display with
-			| DMNone | DMUsage | DMDiagnostics true ->
+			| DMNone | DMUsage | DMDiagnostics true | DMStatistics ->
 				if fctx.is_macro && not ctx.in_macro then
 					()
 				else begin

src/typing/typer.ml

@@ -3947,7 +3947,7 @@ and handle_display ctx e_ast iscall with_type =
 		raise (Display.DisplayPosition pl);
 	| DMToplevel ->
 		raise (Display.DisplayToplevel (ToplevelCollecter.run ctx))
-	| DMDefault | DMNone | DMModuleSymbols | DMDiagnostics _ ->
+	| DMDefault | DMNone | DMModuleSymbols | DMDiagnostics _ | DMStatistics ->
 		let opt_args args ret = TFun(List.map(fun (n,o,t) -> n,true,t) args,ret) in
 		let e,tl_overloads,doc = match e.eexpr with
 			| TField (e1,fa) ->