Browse Source

change com.display to adt in order to support different display modes via --display file@pos@mode

Simon Krajewski 12 years ago
parent
commit
00a2ec641b
6 changed files with 56 additions and 47 deletions
  1. 1 1
      codegen.ml
  2. 10 5
      common.ml
  3. 1 1
      genswf.ml
  4. 24 19
      main.ml
  5. 5 5
      typeload.ml
  6. 15 16
      typer.ml

+ 1 - 1
codegen.ml

@@ -1624,7 +1624,7 @@ module Abstract = struct
 			eright
 
 	let check_cast ctx tleft eright p =
-		if ctx.com.display then eright else do_check_cast ctx tleft eright p
+		if ctx.com.display <> DMNone then eright else do_check_cast ctx tleft eright p
 
 	let find_multitype_specialization a pl p =
 		let m = mk_mono() in

+ 10 - 5
common.ml

@@ -101,12 +101,19 @@ type platform_config = {
 	pf_ignore_unsafe_cast : bool;
 }
 
+type display_mode =
+	| DMNone
+	| DMDefault
+	| DMUsage
+	| DMMetadata
+	| DMPosition
+
 type context = {
 	(* config *)
 	version : int;
 	args : string list;
 	mutable sys_args : string list;
-	mutable display : bool;
+	mutable display : display_mode;
 	mutable debug : bool;
 	mutable verbose : bool;
 	mutable foptimize : bool;
@@ -146,7 +153,7 @@ type context = {
 
 exception Abort of string * Ast.pos
 
-let display_default = ref false
+let display_default = ref DMNone
 
 module Define = struct
 
@@ -161,7 +168,6 @@ module Define = struct
 		| DceDebug
 		| Debug
 		| Display
-		| DisplayMode
 		| DllExport
 		| DllImport
 		| DocGen
@@ -225,7 +231,6 @@ 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)")
 		| DllExport -> ("dll_export", "GenCPP experimental linking")
 		| DllImport -> ("dll_import", "GenCPP experimental linking")
 		| DocGen -> ("doc_gen","Do not perform any removal/change in order to correctly generate documentation")
@@ -630,7 +635,7 @@ let create v args =
 		std_path = [];
 		class_path = [];
 		main_class = None;
-		defines = PMap.add "true" "1" (if !display_default then PMap.add "display" "1" PMap.empty else PMap.empty);
+		defines = PMap.add "true" "1" (if !display_default <> DMNone then PMap.add "display" "1" PMap.empty else PMap.empty);
 		package_rules = PMap.empty;
 		file = "";
 		types = [];

+ 1 - 1
genswf.ml

@@ -483,7 +483,7 @@ let parse_swf com file =
 	IO.close_in ch;
 	List.iter (fun t ->
 		match t.tdata with
-		| TActionScript3 (id,as3) when not com.debug && not com.display ->
+		| TActionScript3 (id,as3) when not com.debug && com.display = DMNone ->
 			t.tdata <- TActionScript3 (id,remove_debug_infos as3)
 		| _ -> ()
 	) tags;

+ 24 - 19
main.ml

@@ -346,7 +346,7 @@ let add_libs com libs =
 			| Some cache ->
 				(try
 					(* if we are compiling, really call haxelib since library path might have changed *)
-					if not com.display then raise Not_found;
+					if com.display = DMNone then raise Not_found;
 					Hashtbl.find cache.c_haxelib libs
 				with Not_found ->
 					let lines = call_haxelib() in
@@ -656,7 +656,7 @@ and wait_loop boot_com host port =
 			end;
 		in
 		let rec cache_context com =
-			if not com.display then begin
+			if com.display = DMNone then begin
 				List.iter cache_module com.modules;
 				if verbose then print_endline ("Cached " ^ string_of_int (List.length com.modules) ^ " modules");
 			end;
@@ -674,7 +674,7 @@ and wait_loop boot_com host port =
 			);
 			ctx.setup <- (fun() ->
 				Parser.display_error := (fun e p -> has_parse_error := true; ctx.com.error (Parser.error_msg e) p);
-				if ctx.com.display then begin
+				if ctx.com.display <> DMNone then begin
 					let file = (!Parser.resume_display).Ast.pfile in
 					let fkey = file ^ "!" ^ get_signature ctx.com in
 					(* force parsing again : if the completion point have been changed *)
@@ -691,7 +691,7 @@ and wait_loop boot_com host port =
 			Unix.clear_nonblock sin;
 			if verbose then print_endline ("Processing Arguments [" ^ String.concat "," data ^ "]");
 			(try
-				Common.display_default := false;
+				Common.display_default := DMNone;
 				Parser.resume_display := Ast.null_pos;
 				Typeload.return_partial_type := false;
 				measure_times := false;
@@ -804,7 +804,7 @@ try
 	com.error <- error ctx;
 	if !global_cache <> None then com.run_command <- run_command ctx;
 	Parser.display_error := (fun e p -> com.error (Parser.error_msg e) p);
-	Parser.use_doc := !Common.display_default || (!global_cache <> None);
+	Parser.use_doc := !Common.display_default <> DMNone || (!global_cache <> None);
 	(try
 		let p = Sys.getenv "HAXE_STD_PATH" in
 		let rec loop = function
@@ -984,9 +984,16 @@ try
 			| _ ->
 				let file, pos = try ExtString.String.split file_pos "@" with _ -> failwith ("Invalid format : " ^ file_pos) in
 				let file = unquote file in
+				let pos, mode = try ExtString.String.split pos "@" with _ -> pos,"" in
+				let mode = match mode with
+					| "position" -> DMPosition
+					| "usage" -> DMUsage
+					| "metadata" -> DMMetadata
+					| _ -> DMDefault
+				in
 				let pos = try int_of_string pos with _ -> failwith ("Invalid format : "  ^ pos) in
-				com.display <- true;
-				Common.display_default := true;
+				com.display <- mode;
+				Common.display_default := mode;
 				Common.define com Define.Display;
 				Parser.use_doc := true;
 				Parser.resume_display := {
@@ -1107,12 +1114,7 @@ try
 	process ctx.com.args;
 	process_libs();
 	(try ignore(Common.find_file com "mt/Include.hx"); Common.raw_define com "mt"; with Not_found -> ());
-	if com.display then begin
-		let mode = Common.defined_value_safe com Define.DisplayMode in
-		if mode = "usage" then begin
-			com.display <- false;
-			Common.display_default := false;
-		end;
+	if com.display <> DMNone then begin
 		com.warning <- message ctx;
 		com.error <- error ctx;
 		com.main_class <- None;
@@ -1184,7 +1186,7 @@ try
 			add_std "java"; "java"
 	) in
 	(* if we are at the last compilation step, allow all packages accesses - in case of macros or opening another project file *)
-	if com.display && not ctx.has_next then com.package_rules <- PMap.foldi (fun p r acc -> match r with Forbidden -> acc | _ -> PMap.add p r acc) com.package_rules PMap.empty;
+	if com.display <> DMNone && not ctx.has_next then com.package_rules <- PMap.foldi (fun p r acc -> match r with Forbidden -> acc | _ -> PMap.add p r acc) com.package_rules PMap.empty;
 	com.config <- get_config com; (* make sure to adapt all flags changes defined after platform *)
 
 	(* check file extension. In case of wrong commandline, we don't want
@@ -1205,9 +1207,12 @@ try
 		Typer.finalize tctx;
 		t();
 		if ctx.has_error then raise Abort;
-		if com.display then begin
-			if ctx.has_next then raise Abort;
-			failwith "No completion point was found";
+		begin match com.display with
+			| DMNone | DMUsage ->
+				()
+			| _ ->
+				if ctx.has_next then raise Abort;
+				failwith "No completion point was found";
 		end;
 		let t = Common.timer "filters" in
 		let main, types, modules = Typer.generate tctx in
@@ -1231,7 +1236,7 @@ try
 			Codegen.remove_generic_base tctx t;
 			Codegen.remove_extern_fields tctx t
 		) com.types;
-		if Common.defined_value_safe com Define.DisplayMode = "usage" then
+		if com.display = DMUsage then
 			Codegen.detect_usage com;
 		let dce_mode = (try Common.defined_value com Define.Dce with _ -> "no") in
 		if not (!gen_as3 || dce_mode = "no" || Common.defined com Define.DocGen) then Dce.run com main (dce_mode = "full" && not !interp);
@@ -1317,7 +1322,7 @@ with
 	| Parser.Error (m,p) ->
 		error ctx (Parser.error_msg m) p
 	| Typecore.Forbid_package ((pack,m,p),pl,pf)  ->
-		if !Common.display_default && ctx.has_next then begin
+		if !Common.display_default <> DMNone && ctx.has_next then begin
 			ctx.has_error <- false;
 			ctx.messages <- [];
 		end else begin

+ 5 - 5
typeload.ml

@@ -1408,7 +1408,7 @@ let init_class ctx c p context_init herits fields =
 		c.cl_extern <- true;
 		List.filter (fun f -> List.mem AStatic f.cff_access) fields, []
 	end else fields, herits in
-	if core_api && not ctx.com.display then delay ctx PForce (fun() -> init_core_api ctx c);
+	if core_api && ctx.com.display = DMNone then delay ctx PForce (fun() -> init_core_api ctx c);
 	let rec extends_public c =
 		Meta.has Meta.PublicFields c.cl_meta ||
 		match c.cl_super with
@@ -1456,7 +1456,7 @@ let init_class ctx c p context_init herits fields =
 
 	(* ----------------------- COMPLETION ----------------------------- *)
 
-	let display_file = if ctx.com.display then Common.unique_full_path p.pfile = (!Parser.resume_display).pfile else false in
+	let display_file = if ctx.com.display <> DMNone then Common.unique_full_path p.pfile = (!Parser.resume_display).pfile else false in
 
 	let cp = !Parser.resume_display in
 
@@ -1469,7 +1469,7 @@ let init_class ctx c p context_init herits fields =
 		| TAbstract _ | TInst _ | TEnum _ | TLazy _ | TDynamic _ | TAnon _ | TType _ -> true
 	in
 	let bind_type ctx cf r p macro =
-		if ctx.com.display then begin
+		if ctx.com.display <> DMNone then begin
 			let cp = !Parser.resume_display in
 			if display_file && (cp.pmin = 0 || (p.pmin <= cp.pmin && p.pmax >= cp.pmax)) then begin
 				if macro && not ctx.in_macro then
@@ -1550,7 +1550,7 @@ let init_class ctx c p context_init herits fields =
 	let loop_cf f =
 		let name = f.cff_name in
 		let p = f.cff_pos in
-		if name.[0] = '$' && not ctx.com.display then error "Field names starting with a dollar are not allowed" p;
+		if name.[0] = '$' && ctx.com.display = DMNone then error "Field names starting with a dollar are not allowed" p;
 		let stat = List.mem AStatic f.cff_access in
 		let extern = Meta.has Meta.Extern f.cff_meta || c.cl_extern in
 		let is_abstract,allow_inline =
@@ -1801,7 +1801,7 @@ let init_class ctx c p context_init herits fields =
 				| _ -> tfun [] ret, tfun [ret] ret
 			in
 			let check_method m t req_name =
-				if ctx.com.display then () else
+				if ctx.com.display <> DMNone then () else
 				try
 					let _, t2, f = (if stat then let f = PMap.find m c.cl_statics in Some c, f.cf_type, f else class_field c m) in
 					(* accessors must be public on As3 (issue #1872) *)

+ 15 - 16
typer.ml

@@ -800,7 +800,7 @@ let rec acc_get ctx g p =
 		ignore(follow f.cf_type); (* force computing *)
 		(match f.cf_expr with
 		| None ->
-			if ctx.com.display then
+			if ctx.com.display <> DMNone then
 				mk (TField (e,cmode)) t p
 			else
 				error "Recursive inline is not supported" p
@@ -1176,7 +1176,7 @@ and type_field ctx e i p mode =
 				This is a fix to deal with optimize_completion which will call iterator()
 				on the expression for/in, which vectors do no have.
 			*)
-			if ctx.com.display && i = "iterator" && c.cl_path = (["flash"],"Vector") then begin
+			if ctx.com.display <> DMNone && i = "iterator" && c.cl_path = (["flash"],"Vector") then begin
 				let it = TAnon {
 					a_fields = PMap.add "next" (mk_field "next" (TFun([],List.hd params)) p) PMap.empty;
 					a_status = ref Closed;
@@ -1999,7 +1999,7 @@ and type_ident ctx i p mode =
 			if ctx.curfun = FunStatic && PMap.mem i ctx.curclass.cl_fields then error ("Cannot access " ^ i ^ " in static function") p;
 			let err = Unknown_ident i in
 			if ctx.in_display then raise (Error (err,p));
-			if ctx.com.display then begin
+			if ctx.com.display <> DMNone then begin
 				display_error ctx (error_msg err) p;
 				let t = mk_mono() in
 				AKExpr (mk (TLocal (add_local ctx i t)) t p)
@@ -2198,7 +2198,7 @@ and type_vars ctx vl p in_block =
 					unify ctx e.etype t p;
 					Some (Codegen.Abstract.check_cast ctx t e p)
 			) in
-			if v.[0] = '$' && not ctx.com.display then error "Variables names starting with a dollar are not allowed" p;
+			if v.[0] = '$' && ctx.com.display = DMNone then error "Variables names starting with a dollar are not allowed" p;
 			add_local ctx v t, e
 		with
 			Error (e,p) ->
@@ -2932,7 +2932,7 @@ 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_safe ctx.com Define.DisplayMode = "usage" ->
+	| EDisplay (e,iscall) when ctx.com.display = DMUsage ->
 		let e = try type_expr ctx e Value with Error (Unknown_ident n,_) -> raise (Parser.TypePath ([n],None)) in
 		begin match e.eexpr with
 		| TField(_,fa) ->
@@ -2955,28 +2955,27 @@ and type_expr ctx (e,p) (with_type:with_type) =
 		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 (e1,fa) ->
-				let mode = Common.defined_value_safe ctx.com Define.DisplayMode in
 				if field_name fa = "bind" then (match follow e1.etype with
 					| TFun(args,ret) -> {e1 with etype = opt_args args ret}
 					| _ -> e)
 				else if field_name fa = "match" then (match follow e1.etype with
 					| TEnum _ as t -> {e1 with etype = tfun [t] ctx.t.tbool }
 					| _ -> e)
-				else if mode = "position" then (match extract_field fa with
+				else if ctx.com.display = DMPosition then (match extract_field fa with
 					| None -> e
 					| Some cf -> raise (Typecore.DisplayPosition [cf.cf_pos]))
-				else if mode = "metadata" then (match fa with
+				else if ctx.com.display = DMMetadata 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_safe ctx.com Define.DisplayMode = "position" ->
+			| TTypeExpr mt when ctx.com.display = DMPosition ->
 				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_safe ctx.com Define.DisplayMode = "metadata" ->
+			| TTypeExpr mt when ctx.com.display = DMMetadata ->
 				raise (DisplayMetadata (match mt with
 					| TClassDecl c -> c.cl_meta
 					| TEnumDecl en -> en.e_meta
@@ -3517,7 +3516,7 @@ let typing_timer ctx f =
 	(*
 		disable resumable errors... unless we are in display mode (we want to reach point of completion)
 	*)
-	if not ctx.com.display then ctx.com.error <- (fun e p -> raise (Error(Custom e,p)));
+	if ctx.com.display = DMNone then ctx.com.error <- (fun e p -> raise (Error(Custom e,p)));
 	if ctx.pass < PTypeField then ctx.pass <- PTypeField;
 	let exit() =
 		t();
@@ -3591,13 +3590,13 @@ let make_macro_api ctx p =
 			typing_timer ctx (fun() -> (type_expr ctx e Value).etype)
 		);
 		Interp.get_display = (fun s ->
-			let is_displaying = ctx.com.display in
+			let is_displaying = ctx.com.display <> DMNone in
 			let old_resume = !Parser.resume_display in
 			let old_error = ctx.on_error in
 			let restore () =
 				if not is_displaying then begin
 					ctx.com.defines <- PMap.remove (fst (Define.infos Define.Display)) ctx.com.defines;
-					ctx.com.display <- false
+					ctx.com.display <- DMNone
 				end;
 				Parser.resume_display := old_resume;
 				ctx.on_error <- old_error;
@@ -3605,7 +3604,7 @@ let make_macro_api ctx p =
 			(* temporarily enter display mode with a fake position *)
 			if not is_displaying then begin
 				Common.define ctx.com Define.Display;
-				ctx.com.display <- true;
+				ctx.com.display <- DMDefault;
 			end;
 			Parser.resume_display := {
 				Ast.pfile = "macro";
@@ -3864,7 +3863,7 @@ let get_macro_context ctx p =
 		ctx.com.get_macros <- (fun() -> Some com2);
 		com2.package_rules <- PMap.empty;
 		com2.main_class <- None;
-		com2.display <- false;
+		com2.display <- DMNone;
 		List.iter (fun p -> com2.defines <- PMap.remove (platform_name p) com2.defines) platforms;
 		com2.defines_signature <- None;
 		com2.class_path <- List.filter (fun s -> not (ExtString.String.exists s "/_std/")) com2.class_path;
@@ -4106,7 +4105,7 @@ let rec create com =
 			delayed = [];
 			debug_delayed = [];
 			delayed_macros = DynArray.create();
-			doinline = not (Common.defined com Define.NoInline || com.display);
+			doinline = not (Common.defined com Define.NoInline || com.display <> DMNone);
 			hook_generate = [];
 			get_build_infos = (fun() -> None);
 			std = null_module;