Custom metadata and defines (documentation, completion)

src-prebuild/prebuild.ml

@@ -259,6 +259,19 @@ type meta_usage =
 	| TTypeParameter
 	| TVariable
 
+let parse_meta_usage = function
+	| \"TClass\" -> TClass
+	| \"TClassField\" -> TClassField
+	| \"TAbstract\" -> TAbstract
+	| \"TAbstractField\" -> TAbstractField
+	| \"TEnum\" -> TEnum
+	| \"TTypedef\" -> TTypedef
+	| \"TAnyField\" -> TAnyField
+	| \"TExpr\" -> TExpr
+	| \"TTypeParameter\" -> TTypeParameter
+	| \"TVariable\" -> TVariable
+	| t -> raise (failwith (\"invalid metadata target \" ^ t))
+
 type meta_parameter =
 	| HasParam of string
 	| Platforms of platform list
@@ -276,10 +289,10 @@ match Array.to_list (Sys.argv) with
 		Printf.printf "%s" define_header;
 		Printf.printf "type strict_defined =\n";
 		Printf.printf "%s" (gen_define_type defines);
-		Printf.printf "\n\t| Last\n\n"; (* must be last *)
+		Printf.printf "\n\t| Last\n\t| Custom of string\n\n";
 		Printf.printf "let infos = function\n";
 		Printf.printf "%s" (gen_define_info defines);
-		Printf.printf "\n\t| Last -> die \"\" __LOC__\n"
+		Printf.printf "\n\t| Last -> die \"\" __LOC__\n\t| Custom s -> s,(\"\",[])\n"
 	| [_; "meta"; meta_path]->
 		let metas = parse_file_array meta_path parse_meta in
 		Printf.printf "%s" meta_header;

src/compiler/args.ml

@@ -146,17 +146,33 @@ let parse_args com =
 			raise (Arg.Help "")
 		),"","show extended help information");
 		("Miscellaneous",["--help-defines"],[], Arg.Unit (fun() ->
-			let all,max_length = Define.get_documentation_list() in
+			let all,max_length = Define.get_documentation_list com.user_defines in
 			let all = List.map (fun (n,doc) -> Printf.sprintf " %-*s: %s" max_length n (limit_string doc (max_length + 3))) all in
 			List.iter (fun msg -> com.print (msg ^ "\n")) all;
 			actx.did_something <- true
 		),"","print help for all compiler specific defines");
+		("Miscellaneous",["--help-user-defines"],[], Arg.Unit (fun() ->
+			com.callbacks#add_after_init_macros (fun() ->
+				let all,max_length = Define.get_user_documentation_list com.user_defines in
+				let all = List.map (fun (n,doc) -> Printf.sprintf " %-*s: %s" max_length n (limit_string doc (max_length + 3))) all in
+				List.iter (fun msg -> com.print (msg ^ "\n")) all;
+				exit 0
+			)
+		),"","print help for all user defines");
 		("Miscellaneous",["--help-metas"],[], Arg.Unit (fun() ->
-			let all,max_length = Meta.get_documentation_list() in
+			let all,max_length = Meta.get_documentation_list com.user_metas in
 			let all = List.map (fun (n,doc) -> Printf.sprintf " %-*s: %s" max_length n (limit_string doc (max_length + 3))) all in
 			List.iter (fun msg -> com.print (msg ^ "\n")) all;
 			actx.did_something <- true
 		),"","print help for all compiler metadatas");
+		("Miscellaneous",["--help-user-metas"],[], Arg.Unit (fun() ->
+			com.callbacks#add_after_init_macros (fun() ->
+				let all,max_length = Meta.get_user_documentation_list com.user_metas in
+				let all = List.map (fun (n,doc) -> Printf.sprintf " %-*s: %s" max_length n (limit_string doc (max_length + 3))) all in
+				List.iter (fun msg -> com.print (msg ^ "\n")) all;
+				exit 0
+			)
+		),"","print help for all user metadatas");
 	] in
 	let adv_args_spec = [
 		("Optimization",["--dce"],["-dce"],Arg.String (fun mode ->

src/compiler/compiler.ml

@@ -616,4 +616,4 @@ module HighLevel = struct
 		in
 		let code = loop args in
 		comm.exit code
-end
+end

src/compiler/displayOutput.ml

@@ -71,7 +71,7 @@ let print_fields fields =
 		| ITPackage(path,_) -> "package",snd path,"",None
 		| ITModule path -> "type",snd path,"",None
 		| ITMetadata  meta ->
-			let s,(doc,_) = Meta.get_info meta in
+			let s,(doc,_),_ = Meta.get_info meta in
 			"metadata","@" ^ s,"",doc_from_string doc
 		| ITTimer(name,value) -> "timer",name,"",doc_from_string value
 		| ITLiteral s ->

src/context/common.ml

@@ -363,6 +363,8 @@ type context = {
 	mutable load_extern_type : (string * (path -> pos -> Ast.package option)) list; (* allow finding types which are not in sources *)
 	callbacks : compiler_callbacks;
 	defines : Define.define;
+	mutable user_defines : (string, Define.user_define) Hashtbl.t;
+	mutable user_metas : (string, Meta.user_meta) Hashtbl.t;
 	mutable get_macros : unit -> context option;
 	(* typing state *)
 	shared : shared_context;
@@ -543,7 +545,7 @@ let default_config =
 	}
 
 let get_config com =
-	let defined f = PMap.mem (fst (Define.infos f)) com.defines.values in
+	let defined f = PMap.mem (Define.get_define_key f) com.defines.values in
 	match com.platform with
 	| Cross ->
 		default_config
@@ -809,6 +811,8 @@ let create compilation_step cs version args =
 			defines_signature = None;
 			values = PMap.empty;
 		};
+		user_defines = Hashtbl.create 0;
+		user_metas = Hashtbl.create 0;
 		get_macros = (fun() -> None);
 		info = (fun _ _ -> die "" __LOC__);
 		warning = (fun _ _ _ -> die "" __LOC__);

src/context/display/displayEmitter.ml

@@ -145,15 +145,15 @@ let display_meta com meta p = match com.display.dms_kind with
 		begin match meta with
 		| Meta.Custom _ | Meta.Dollar _ -> ()
 		| _ ->
-			if com.json_out = None then begin match Meta.get_documentation meta with
+			if com.json_out = None then begin match Meta.get_documentation com.user_metas meta with
 				| None -> ()
 				| Some (_,s) ->
 					raise_metadata ("<metadata>" ^ s ^ "</metadata>")
 			end else
 				raise_hover (make_ci_metadata meta) None p
 		end
 	| DMDefault ->
-		let all = Meta.get_all() in
+		let all = Meta.get_all com.user_metas in
 		let all = List.map make_ci_metadata all in
 		let subject = if meta = Meta.HxCompletion then None else Some (Meta.to_string meta) in
 		raise_fields all CRMetadata (make_subject subject p);

src/core/ast.ml

@@ -1198,7 +1198,7 @@ module Expr = struct
 				add "ECheckType";
 				loop e1;
 			| EMeta((m,_,_),e1) ->
-				add ("EMeta " ^ fst (Meta.get_info m));
+				add ("EMeta " ^ (Meta.to_string m));
 				loop e1
 		in
 		loop' "" e;

src/core/define.ml

@@ -6,34 +6,76 @@ type define = {
 	mutable defines_signature : string option;
 }
 
+type user_define = {
+	doc : string;
+	flags : define_parameter list;
+	source : string option;
+}
+
+let register_user_define user_defines s data =
+	Hashtbl.replace user_defines s data
+
+type define_origin =
+	| Compiler
+	| UserDefined of string option
+
+let infos ?user_defines d = match (user_defines,d) with
+	| (Some(user_defines), Custom(s)) when (Hashtbl.mem user_defines s) ->
+		let infos = Hashtbl.find user_defines s in
+		(s, (infos.doc, infos.flags), (UserDefined infos.source))
+	| (_, Custom(s)) ->
+		(s, ("", []), Compiler)
+	| _ ->
+		let def,infos = DefineList.infos d in
+		(def, infos, Compiler)
+
 let get_define_key d =
-	fst (infos d)
+	match (infos d) with (s,_,_) -> s
 
-let get_documentation_list() =
+let get_documentation user_defines d =
+	let t, (doc,flags), origin = infos ~user_defines:user_defines d in
+	let params = ref [] and pfs = ref [] in
+	List.iter (function
+		| HasParam s -> params := s :: !params
+		| Platforms fl -> pfs := fl @ !pfs
+		| Link _ -> ()
+	) flags;
+	let params = (match List.rev !params with
+		| [] -> ""
+		| l -> "<" ^ String.concat ">, <" l ^ "> "
+	) in
+	let origin = match origin with
+		| UserDefined Some s -> " (from " ^ s ^ ")"
+		| Compiler | UserDefined None -> ""
+	in
+	let pfs = platform_list_help (List.rev !pfs) in
+	(String.concat "-" (ExtString.String.nsplit t "_")), params ^ doc ^ pfs ^ origin
+
+let get_documentation_list user_defines =
 	let m = ref 0 in
 	let rec loop i =
 		let d = Obj.magic i in
 		if d <> Last then begin
-			let t, (doc,flags) = infos d in
-			let params = ref [] and pfs = ref [] in
-			List.iter (function
-				| HasParam s -> params := s :: !params
-				| Platforms fl -> pfs := fl @ !pfs
-				| Link _ -> ()
-			) flags;
-			let params = (match List.rev !params with
-				| [] -> ""
-				| l -> "<" ^ String.concat ">, <" l ^ "> "
-			) in
-			let pfs = platform_list_help (List.rev !pfs) in
-			if String.length t > !m then m := String.length t;
-			((String.concat "-" (ExtString.String.nsplit t "_")), params ^ doc ^ pfs) :: (loop (i + 1))
+			let (str,desc) = get_documentation user_defines d in
+			if String.length str > !m then m := String.length str;
+			(str,desc) :: loop (i + 1)
 		end else
 			[]
 	in
 	let all = List.sort (fun (s1,_) (s2,_) -> String.compare s1 s2) (loop 0) in
 	all,!m
 
+let get_user_documentation_list user_defines =
+	let m = ref 0 in
+	let user_defines_list = (Hashtbl.fold (fun d _ acc ->
+		let (str,desc) = get_documentation user_defines (Custom d) in
+		if String.length str > !m then m := String.length str;
+		(str,desc) :: acc
+	) user_defines []) in
+
+	let all = List.sort (fun (s1,_) (s2,_) -> String.compare s1 s2) user_defines_list in
+	all,!m
+
 let raw_defined ctx k =
 	PMap.mem k ctx.values
 
@@ -44,7 +86,7 @@ let raw_defined_value ctx k =
 	PMap.find k ctx.values
 
 let defined_value ctx v =
-	raw_defined_value ctx (fst (infos v))
+	raw_defined_value ctx (get_define_key v)
 
 let defined_value_safe ?default ctx v =
 	try defined_value ctx v

src/core/display/completionItem.ml

@@ -759,7 +759,7 @@ let to_json ctx index item =
 		]
 		| ITMetadata meta ->
 			let open Meta in
-			let name,(doc,params) = Meta.get_info meta in
+			let name,(doc,params),origin = Meta.get_info meta in
 			let name = "@" ^ name in
 			let usage_to_string = function
 				| TClass -> "TClass"
@@ -773,6 +773,10 @@ let to_json ctx index item =
 				| TTypeParameter -> "TTypeParameter"
 				| TVariable -> "TVariable"
 			in
+			let origin = match origin with
+				| Compiler -> Some "haxe compiler"
+				| UserDefined s -> s
+			in
 			let rec loop internal params platforms targets links l = match l with
 				| HasParam s :: l -> loop internal (s :: params) platforms targets links l
 				| Platforms pls :: l -> loop internal params ((List.map platform_name pls) @ platforms) targets links l
@@ -790,6 +794,7 @@ let to_json ctx index item =
 				"targets",jlist jstring targets;
 				"internal",jbool internal;
 				"links",jlist jstring links;
+				"origin",jopt jstring origin;
 			]
 		| ITKeyword kwd ->"Keyword",jobject [
 			"name",jstring (s_keyword kwd)
@@ -828,4 +833,4 @@ let to_json ctx index item =
 			| Some t ->
 				("type",CompletionType.to_json ctx (snd t)) :: jindex
 		)
-	)
+	)

src/core/globals.ml

@@ -64,6 +64,21 @@ let platform_name = function
 	| Hl -> "hl"
 	| Eval -> "eval"
 
+let parse_platform = function
+	| "cross" -> Cross
+	| "js" -> Js
+	| "lua" -> Lua
+	| "neko" -> Neko
+	| "flash" -> Flash
+	| "php" -> Php
+	| "cpp" -> Cpp
+	| "cs" -> Cs
+	| "java" -> Java
+	| "python" -> Python
+	| "hl" -> Hl
+	| "eval" -> Eval
+	| p -> raise (failwith ("invalid platform " ^ p))
+
 let platform_list_help = function
 	| [] -> ""
 	| [p] -> " (" ^ platform_name p ^ " only)"

src/core/json/genjson.ml

@@ -177,7 +177,7 @@ and generate_metadata_entry ctx (m,el,p) =
 
 and generate_metadata ctx ml =
 	let ml = List.filter (fun (m,_,_) ->
-		let (_,(_,flags)) = Meta.get_info m in
+		let (_,(_,flags),_) = Meta.get_info m in
 		not (List.mem UsedInternally flags)
 	) ml in
 	jlist (generate_metadata_entry ctx) ml