initial support for -D display-mode=usage|metadata|position (no parser yet)

ast.ml

@@ -121,6 +121,7 @@ module Meta = struct
 		| UnifyMinDynamic
 		| Unreflective
 		| Unsafe
+		| Usage
 		| Used
 		| Dollar of string
 		| Custom of string
@@ -222,6 +223,7 @@ module Meta = struct
 		| UnifyMinDynamic -> ":unifyMinDynamic"
 		| Unreflective -> ":unreflective"
 		| Unsafe -> ":unsafe"
+		| Usage -> ":usage"
 		| Used -> ":used"
 		| Dollar s -> "$" ^ s
 		| Custom s -> s

codegen.ml

@@ -1444,6 +1444,32 @@ let handle_abstract_casts ctx e =
 	in
 	loop e
 
+(* -------------------------------------------------------------------------- *)
+(* USAGE *)
+
+let detect_usage com =
+	let usage = ref [] in
+	List.iter (fun t -> match t with
+		| TClassDecl c ->
+			let rec expr e = match e.eexpr with
+				| TField(_,fa) ->
+					(match extract_field fa with
+						| Some cf when Meta.has Meta.Usage cf.cf_meta ->
+							usage := e.epos :: !usage;
+						| _ -> ());
+					Type.iter expr e
+				| _ -> Type.iter expr e
+			in
+			let field cf = match cf.cf_expr with None -> () | Some e -> expr e in
+			(match c.cl_constructor with None -> () | Some cf -> field cf);
+			(match c.cl_init with None -> () | Some e -> expr e);
+			List.iter field c.cl_ordered_statics;
+			List.iter field c.cl_ordered_fields;
+		| _ -> ()
+	) com.types;
+	let usage = List.sort (fun p1 p2 -> compare p1.pmin p2.pmin) !usage in
+	raise (Typecore.DisplayPosition usage)
+
 (* -------------------------------------------------------------------------- *)
 (* POST PROCESS *)
 

common.ml

@@ -146,6 +146,7 @@ module Define = struct
 		| DceDebug
 		| Debug
 		| Display
+		| DisplayMode
 		| DocGen
 		| Dump
 		| DumpDependencies
@@ -205,6 +206,7 @@ module Define = struct
 		| DceDebug -> ("dce_debug","Show DCE log")
 		| Debug -> ("debug","Activated when compiling with -debug")
 		| Display -> ("display","Activated during completion")
+		| DisplayMode -> ("display_mode", "The display mode to use (default, position, metadata, usage)")
 		| DocGen -> ("doc_gen","Do not perform any removal/change in order to correctly generate documentation")
 		| Dump -> ("dump","Dump the complete typed AST for internal debugging")
 		| DumpDependencies -> ("dump_dependencies","Dump the classes dependencies")

main.ml

@@ -1005,6 +1005,14 @@ try
 	loop();
 	(try ignore(Common.find_file com "mt/Include.hx"); Common.raw_define com "mt"; with Not_found -> ());
 	if com.display then begin
+		(try
+			let mode = Common.defined_value com Define.DisplayMode in
+			if mode = "usage" then begin
+				com.display <- false;
+				Common.display_default := false;
+			end
+		with Not_found ->
+			Common.define_value com Define.DisplayMode "default");
 		com.warning <- message ctx;
 		com.error <- error ctx;
 		com.main_class <- None;
@@ -1101,6 +1109,8 @@ try
 		com.main <- main;
 		com.types <- types;
 		com.modules <- modules;
+		if Common.defined_value com Define.DisplayMode = "usage" then
+			Codegen.detect_usage com;
 		let filters = [
 			Codegen.handle_abstract_casts tctx;
 			if com.foptimize then Optimizer.reduce_expression tctx else Optimizer.sanitize tctx;
@@ -1234,6 +1244,27 @@ with
 			Buffer.add_string b "\n</type>\n";
 		) tl;
 		raise (Completion (Buffer.contents b))
+	| Typecore.DisplayPosition pl ->
+		let b = Buffer.create 0 in
+		let error_printer file line = sprintf "%s:%d:" (Common.unique_full_path file) line in
+		List.iter (fun p ->
+			let epos = Lexer.get_error_pos error_printer p in
+			Buffer.add_string b "<pos>\n";
+			Buffer.add_string b epos;
+			Buffer.add_string b "\n</pos>\n";
+		) pl;
+		raise (Completion (Buffer.contents b))
+	| Typer.DisplayMetadata m ->
+		let b = Buffer.create 0 in
+		List.iter (fun (m,el,p) ->
+			Buffer.add_string b ("<meta name=\"" ^ (Ast.Meta.to_string m) ^ "\"");
+			if el = [] then Buffer.add_string b "/>" else begin
+				Buffer.add_string b ">\n";
+				List.iter (fun e -> Buffer.add_string b ((htmlescape (Genxml.sexpr e)) ^ "\n")) el;
+				Buffer.add_string b "</meta>\n";
+			end
+		) m;
+		raise (Completion (Buffer.contents b))
 	| Parser.TypePath (p,c) ->
 		(match c with
 		| None ->

type.ml

@@ -314,6 +314,10 @@ let field_name f =
 	| FEnum (_,f) -> f.ef_name
 	| FDynamic n -> n
 
+let extract_field = function
+	| FAnon f | FInstance (_,f) | FStatic (_,f) | FClosure (_,f) -> Some f
+	| _ -> None
+
 let mk_class m path pos =
 	{
 		cl_path = path;

typecore.ml

@@ -127,6 +127,8 @@ exception Forbid_package of (string * path * pos) * pos list * string
 
 exception Error of error_msg * pos
 
+exception DisplayPosition of Ast.pos list
+
 let type_expr_ref : (typer -> Ast.expr -> with_type -> texpr) ref = ref (fun _ _ _ -> assert false)
 let unify_min_ref : (typer -> texpr list -> t) ref = ref (fun _ _ -> assert false)
 let match_expr_ref : (typer -> Ast.expr -> (Ast.expr list * Ast.expr option * Ast.expr option) list -> Ast.expr option option -> with_type -> Ast.pos -> texpr) ref = ref (fun _ _ _ _ _ _ -> assert false)

typer.ml

@@ -35,6 +35,7 @@ type access_mode =
 
 exception DisplayTypes of t list
 exception DisplayFields of (string * t * documentation) list
+exception DisplayMetadata of metadata_entry list
 exception WithTypeError of unify_error list * pos
 
 type access_kind =
@@ -2484,17 +2485,48 @@ and type_expr ctx (e,p) (with_type:with_type) =
 			error "Cast type must be a class or an enum" p
 		) in
 		mk (TCast (type_expr ctx e Value,Some texpr)) t p
+	| EDisplay (e,iscall) when Common.defined_value ctx.com Define.DisplayMode = "usage" ->
+		let e = try type_expr ctx e Value with Error (Unknown_ident n,_) -> raise (Parser.TypePath ([n],None)) in
+		(match e.eexpr with
+		| TField(_,fa) -> (match extract_field fa with
+			| None -> e
+			| Some cf ->
+				cf.cf_meta <- (Meta.Usage,[],p) :: cf.cf_meta;
+				e)
+		| _ -> e)
 	| EDisplay (e,iscall) ->
 		let old = ctx.in_display in
 		let opt_args args ret = TFun(List.map(fun (n,o,t) -> n,true,t) args,ret) in
 		ctx.in_display <- true;
 		let e = (try type_expr ctx e Value with Error (Unknown_ident n,_) -> raise (Parser.TypePath ([n],None))) in
 		let e = match e.eexpr with
-			| TField (e,f) when field_name f = "bind" ->
-				(match follow e.etype with
-				| TFun(args,ret) -> {e with etype = opt_args args ret}
-				| _ -> e)
-			| _ -> e
+			| TField (e,fa) ->
+				let mode = Common.defined_value ctx.com Define.DisplayMode in
+				if field_name fa = "bind" then (match follow e.etype with
+					| TFun(args,ret) -> {e with etype = opt_args args ret}
+					| _ -> e)
+				else if mode = "position" then (match extract_field fa with
+					| None -> e
+					| Some cf -> raise (Typecore.DisplayPosition [cf.cf_pos]))
+				else if mode = "metadata" then (match fa with
+					| FStatic (c,cf) | FInstance (c,cf) | FClosure(Some c,cf) -> raise (DisplayMetadata (c.cl_meta @ cf.cf_meta))
+					| _ -> e)
+				else
+					e
+			| TTypeExpr mt when Common.defined_value ctx.com Define.DisplayMode = "position" ->
+				raise (DisplayPosition [match mt with
+					| TClassDecl c -> c.cl_pos
+					| TEnumDecl en -> en.e_pos
+					| TTypeDecl t -> t.t_pos
+					| TAbstractDecl a -> a.a_pos])
+			| TTypeExpr mt when Common.defined_value ctx.com Define.DisplayMode = "metadata" ->
+				raise (DisplayMetadata (match mt with
+					| TClassDecl c -> c.cl_meta
+					| TEnumDecl en -> en.e_meta
+					| TTypeDecl t -> t.t_meta
+					| TAbstractDecl a -> a.a_meta))
+			| _ ->
+				e
 		in
 		ctx.in_display <- old;
 		let opt_type t =