[display] unify display exceptions

src/compiler/displayOutput.ml

@@ -3,6 +3,7 @@ open Common
 open Timer
 open DisplayTypes.DisplayMode
 open DisplayTypes.CompletionKind
+open Display.DisplayException
 open Type
 open Display
 open DisplayTypes
@@ -754,7 +755,7 @@ let process_display_file com classes =
 			let real = Path.get_real_path (!Parser.resume_display).pfile in
 			let path = match get_module_path_from_file_path com real with
 			| Some path ->
-				if com.display.dms_kind = DMPackage then raise (DisplayPackage (fst path));
+				if com.display.dms_kind = DMPackage then raise_package (fst path);
 				classes := path :: !classes;
 				Some path
 			| None ->
@@ -789,13 +790,13 @@ let process_global_display_mode com tctx = match com.display.dms_kind with
 			if c <> 0 then c else compare p1.pmin p2.pmin
 		) usages in
 		Display.reference_position := null_pos;
-		raise (DisplayPosition usages)
+		raise_position usages
 	| DMDiagnostics global ->
 		Diagnostics.prepare com global;
-		raise (Diagnostics (DiagnosticsPrinter.print_diagnostics tctx global))
+		raise_diagnostics (DiagnosticsPrinter.print_diagnostics tctx global)
 	| DMStatistics ->
 		let stats = Statistics.collect_statistics tctx in
-		raise (Statistics (StatisticsPrinter.print_statistics stats))
+		raise_statistics (StatisticsPrinter.print_statistics stats)
 	| DMModuleSymbols filter ->
 		let symbols = com.shared.shared_display_information.document_symbols in
 		let symbols = match CompilationServer.get() with
@@ -809,7 +810,7 @@ let process_global_display_mode com tctx = match com.display.dms_kind with
 						acc
 				) symbols l
 		in
-		raise (ModuleSymbols(ModuleSymbolsPrinter.print_module_symbols com symbols filter))
+		raise_module_symbols (ModuleSymbolsPrinter.print_module_symbols com symbols filter)
 	| _ -> ()
 
 let find_doc t =

src/compiler/main.ml

@@ -45,6 +45,7 @@
 open Printf
 open Common
 open DisplayTypes.DisplayMode
+open Display.DisplayException
 open Type
 open Server
 open Globals
@@ -826,14 +827,19 @@ try
 		Finalization.finalize tctx;
 		t();
 		if not ctx.com.display.dms_display && ctx.has_error then raise Abort;
-		(* TODO: We don't want this to cause any errors. Needs proper exception handling that doesn't swallow display exceptions... *)
 		let load_display_module_in_macro () = match display_file_dot_path with
 			| Some cpath ->
 				let p = null_pos in
-				let _ = MacroContext.load_macro_module tctx cpath true p in
-				let _, mctx = MacroContext.get_macro_context tctx p in
-				Finalization.finalize mctx;
-				Some mctx
+				begin try
+					let _ = MacroContext.load_macro_module tctx cpath true p in
+					let _, mctx = MacroContext.get_macro_context tctx p in
+					Finalization.finalize mctx;
+					Some mctx
+				with DisplayException _ | Parser.TypePath _ as exc ->
+					raise exc
+				| _ ->
+					None
+				end
 			| None ->
 				None
 		in
@@ -921,9 +927,9 @@ with
 		error ctx ("Error: " ^ msg) null_pos
 	| HelpMessage msg ->
 		message ctx (CMInfo(msg,null_pos))
-	| Display.DisplayPackage pack ->
+	| DisplayException(DisplayPackage pack) ->
 		raise (DisplayOutput.Completion (DisplayOutput.print_package ctx.com pack))
-	| Display.DisplayFields(fields,is_toplevel) ->
+	| DisplayException(DisplayFields(fields,is_toplevel)) ->
 		let fields =
 			if !measure_times then begin
 				Timer.close_times();
@@ -934,15 +940,15 @@ with
 				fields
 		in
 		raise (DisplayOutput.Completion (DisplayOutput.print_fields ctx.com fields is_toplevel))
-	| Display.DisplayType (t,p,doc) ->
+	| DisplayException(DisplayType (t,p,doc)) ->
 		let doc = match doc with Some _ -> doc | None -> DisplayOutput.find_doc t in
 		raise (DisplayOutput.Completion (DisplayOutput.print_type ctx.com t p doc))
-	| Display.DisplaySignatures(signatures,display_arg) ->
+	| DisplayException(DisplaySignatures(signatures,display_arg)) ->
 		if ctx.com.display.dms_kind = DMSignature then
 			raise (DisplayOutput.Completion (DisplayOutput.print_signature signatures display_arg))
 		else
 			raise (DisplayOutput.Completion (DisplayOutput.print_signatures signatures))
-	| Display.DisplayPosition pl ->
+	| DisplayException(DisplayPosition pl) ->
 		raise (DisplayOutput.Completion (DisplayOutput.print_positions ctx.com pl))
 	| Parser.TypePath (p,c,is_import) ->
 		let fields =
@@ -956,7 +962,7 @@ with
 				None
 		in
 		Option.may (fun fields -> raise (DisplayOutput.Completion (DisplayOutput.print_fields ctx.com fields false))) fields
-	| Display.ModuleSymbols s | Display.Diagnostics s | Display.Statistics s | Display.Metadata s ->
+	| DisplayException(ModuleSymbols s | Diagnostics s | Statistics s | Metadata s) ->
 		raise (DisplayOutput.Completion s)
 	| EvalExceptions.Sys_exit i | Hlinterp.Sys_exit i ->
 		ctx.flush();

src/context/display.ml

@@ -8,15 +8,32 @@ open Globals
 
 let reference_position = ref null_pos
 
-exception Diagnostics of string
-exception Statistics of string
-exception ModuleSymbols of string
-exception Metadata of string
-exception DisplaySignatures of (tsignature * documentation) list * int
-exception DisplayType of t * pos * string option
-exception DisplayPosition of pos list
-exception DisplayFields of DisplayTypes.CompletionKind.t list * bool (* toplevel? *)
-exception DisplayPackage of string list
+module DisplayException = struct
+	type kind =
+		| Diagnostics of string
+		| Statistics of string
+		| ModuleSymbols of string
+		| Metadata of string
+		| DisplaySignatures of (tsignature * documentation) list * int
+		| DisplayType of t * pos * string option
+		| DisplayPosition of pos list
+		| DisplayFields of DisplayTypes.CompletionKind.t list * bool (* toplevel? *)
+		| DisplayPackage of string list
+
+	exception DisplayException of kind
+
+	let raise_diagnostics s = raise (DisplayException(Diagnostics s))
+	let raise_statistics s = raise (DisplayException(Statistics s))
+	let raise_module_symbols s = raise (DisplayException(ModuleSymbols s))
+	let raise_metadata s = raise (DisplayException(Metadata s))
+	let raise_signatures l i = raise (DisplayException(DisplaySignatures(l,i)))
+	let raise_type t p so = raise (DisplayException(DisplayType(t,p,so)))
+	let raise_position pl = raise (DisplayException(DisplayPosition pl))
+	let raise_fields ckl b = raise (DisplayException(DisplayFields(ckl,b)))
+	let raise_package sl = raise (DisplayException(DisplayPackage sl))
+end
+
+open DisplayException
 
 let is_display_file file =
 	file <> "?" && Path.unique_full_path file = (!Parser.resume_display).pfile
@@ -122,13 +139,13 @@ end
 
 module DisplayEmitter = struct
 	let display_module_type dm mt p = match dm.dms_kind with
-		| DMDefinition -> raise (DisplayPosition [(t_infos mt).mt_name_pos]);
+		| DMDefinition -> raise_position [(t_infos mt).mt_name_pos];
 		| DMUsage _ -> reference_position := (t_infos mt).mt_name_pos
-		| DMHover -> raise (DisplayType (type_of_module_type mt,p,None))
+		| DMHover -> raise_type (type_of_module_type mt) p None
 		| _ -> ()
 
 	let rec display_type dm t p = match dm.dms_kind with
-		| DMHover -> raise (DisplayType (t,p,None))
+		| DMHover -> raise_type t p None
 		| _ ->
 			try display_module_type dm (module_type_of_type t) p
 			with Exit -> match follow t,follow !t_dynamic_def with
@@ -151,13 +168,13 @@ module DisplayEmitter = struct
 		| _ -> maybe_display_type()
 
 	let display_variable dm v p = match dm.dms_kind with
-		| DMDefinition -> raise (DisplayPosition [v.v_pos])
+		| DMDefinition -> raise_position [v.v_pos]
 		| DMUsage _ -> reference_position := v.v_pos
-		| DMHover -> raise (DisplayType (v.v_type,p,None))
+		| DMHover -> raise_type v.v_type p None
 		| _ -> ()
 
 	let display_field dm cf p = match dm.dms_kind with
-		| DMDefinition -> raise (DisplayPosition [cf.cf_name_pos]);
+		| DMDefinition -> raise_position [cf.cf_name_pos]
 		| DMUsage _ -> reference_position := cf.cf_name_pos
 		| DMHover ->
 			let t = if Meta.has Meta.Impl cf.cf_meta then
@@ -165,16 +182,16 @@ module DisplayEmitter = struct
 			else
 				cf.cf_type
 			in
-			raise (DisplayType (t,p,cf.cf_doc))
+			raise_type t p cf.cf_doc
 		| _ -> ()
 
 	let maybe_display_field ctx p cf =
 		if is_display_position p then display_field ctx.com.display cf p
 
 	let display_enum_field dm ef p = match dm.dms_kind with
-		| DMDefinition -> raise (DisplayPosition [ef.ef_name_pos]);
+		| DMDefinition -> raise_position [ef.ef_name_pos]
 		| DMUsage _ -> reference_position := ef.ef_name_pos
-		| DMHover -> raise (DisplayType (ef.ef_type,p,ef.ef_doc))
+		| DMHover -> raise_type ef.ef_type p ef.ef_doc
 		| _ -> ()
 
 	let display_meta com meta = match com.display.dms_kind with
@@ -186,16 +203,16 @@ module DisplayEmitter = struct
 				| Some (_,s) ->
 					(* TODO: hack until we support proper output for hover display mode *)
 					if com.json_out = None then
-						raise (Metadata ("<metadata>" ^ s ^ "</metadata>"))
+						raise_metadata ("<metadata>" ^ s ^ "</metadata>")
 					else
-						raise (DisplayType(t_dynamic,null_pos,Some s));
+						raise_type t_dynamic null_pos (Some s)
 			end
 		| DMDefault ->
 			let all,_ = Meta.get_documentation_list() in
 			let all = List.map (fun (s,doc) ->
 				ITMetadata(s,Some doc)
 			) all in
-			raise (DisplayFields(all,false))
+			raise_fields all false
 		| _ ->
 			()
 

src/typing/typeload.ml

@@ -39,7 +39,7 @@ let type_function_params_rec = ref (fun _ _ _ _ -> assert false)
 let rec load_type_def ctx p t =
 	let no_pack = t.tpackage = [] in
 	let tname = (match t.tsub with None -> t.tname | Some n -> n) in
-	if tname = "" then raise (Display.DisplayFields (DisplayToplevel.collect ctx true NoValue,true));
+	if tname = "" then Display.DisplayException.raise_fields (DisplayToplevel.collect ctx true NoValue) true;
 	try
 		if t.tsub <> None then raise Not_found;
 		let path_matches t2 =
@@ -116,7 +116,7 @@ let rec load_type_def ctx p t =
 let resolve_position_by_path ctx path p =
 	let mt = load_type_def ctx p path in
 	let p = (t_infos mt).mt_pos in
-	raise (Display.DisplayPosition [p])
+	Display.DisplayException.raise_position [p]
 
 let check_param_constraints ctx types t pl c p =
 	match follow t with
@@ -710,7 +710,7 @@ let handle_path_display ctx path p =
 			   which might not even exist anyway. *)
 			let mt = ctx.g.do_load_module ctx (sl,s) p in
 			let p = { pfile = mt.m_extra.m_file; pmin = 0; pmax = 0} in
-			raise (Display.DisplayPosition [p])
+			Display.DisplayException.raise_position [p]
 		| (IDKModule(sl,s),_),_ ->
 			(* TODO: wait till nadako requests @type display for these, then implement it somehow *)
 			raise (Parser.TypePath(sl,Some(s,false),true))

src/typing/typeloadFunction.ml

@@ -24,6 +24,7 @@ open Ast
 open Type
 open Typecore
 open DisplayTypes.DisplayMode
+open Display.DisplayException
 open Common
 open Error
 
@@ -116,7 +117,7 @@ let type_function ctx args ret fmode f do_display p =
 		with
 		| Parser.TypePath (_,None,_) | Exit ->
 			type_expr ctx e NoValue
-		| Display.DisplayType (t,_,_) when (match follow t with TMono _ -> true | _ -> false) ->
+		| DisplayException (DisplayType (t,_,_)) when (match follow t with TMono _ -> true | _ -> false) ->
 			type_expr ctx e NoValue
 	end in
 	let e = match e.eexpr with

src/typing/typeloadModule.ml

@@ -360,7 +360,7 @@ let init_module_type ctx context_init do_init (decl,p) =
 				ctx.m.wildcard_packages <- (List.map fst pack,p) :: ctx.m.wildcard_packages
 			| _ ->
 				(match List.rev path with
-				| [] -> raise (Display.DisplayFields (DisplayToplevel.collect ctx true NoValue,true));
+				| [] -> Display.DisplayException.raise_fields (DisplayToplevel.collect ctx true NoValue) true;
 				| (_,p) :: _ -> error "Module name must start with an uppercase letter" p))
 		| (tname,p2) :: rest ->
 			let p1 = (match pack with [] -> p2 | (_,p1) :: _ -> p1) in
@@ -469,7 +469,7 @@ let init_module_type ctx context_init do_init (decl,p) =
 			| (s1,_) :: sl ->
 				{ tpackage = List.rev (List.map fst sl); tname = s1; tsub = None; tparams = [] }
 			| [] ->
-				raise (Display.DisplayFields (DisplayToplevel.collect ctx true NoValue,true));
+				Display.DisplayException.raise_fields (DisplayToplevel.collect ctx true NoValue) true;
 		in
 		(* do the import first *)
 		let types = (match t.tsub with

src/typing/typerDisplay.ml

@@ -1,6 +1,7 @@
 open Globals
 open Ast
 open DisplayTypes.DisplayMode
+open Display.DisplayException
 open Common
 open Type
 open Typecore
@@ -20,9 +21,9 @@ let rec handle_display ctx e_ast dk with_type =
 		let arg = ["expression",false,mono] in
 		begin match ctx.com.display.dms_kind with
 		| DMSignature ->
-			raise (Display.DisplaySignatures ([((arg,mono),doc)],0))
+			raise_signatures [((arg,mono),doc)] 0
 		| _ ->
-			raise (Display.DisplayType(TFun(arg,mono),(pos e_ast),doc))
+			raise_type (TFun(arg,mono)) (pos e_ast) doc
 		end
 	| (EConst (Ident "trace"),_),_ ->
 		let doc = Some "Print given arguments" in
@@ -30,9 +31,9 @@ let rec handle_display ctx e_ast dk with_type =
 		let ret = ctx.com.basic.tvoid in
 		begin match ctx.com.display.dms_kind with
 		| DMSignature ->
-			raise (Display.DisplaySignatures ([((arg,ret),doc)],0))
+			raise_signatures [((arg,ret),doc)] 0
 		| _ ->
-			raise (Display.DisplayType(TFun(arg,ret),(pos e_ast),doc))
+			raise_type (TFun(arg,ret)) (pos e_ast) doc
 		end
 	| (EConst (Ident "_"),p),WithType t ->
 		mk (TConst TNull) t p (* This is "probably" a bind skip, let's just use the expected type *)
@@ -42,7 +43,7 @@ let rec handle_display ctx e_ast dk with_type =
 		raise (Parser.TypePath ([n],None,false))
 	| Error (Type_not_found (path,_),_) as err ->
 		begin try
-			raise (Display.DisplayFields (DisplayFields.get_submodule_fields ctx path,false))
+			raise_fields (DisplayFields.get_submodule_fields ctx path) false
 		with Not_found ->
 			raise err
 		end
@@ -92,7 +93,7 @@ and handle_signature_display ctx e_ast with_type =
 				acc
 		in
 		let overloads = match loop [] tl with [] -> tl | tl -> tl in
-		raise (Display.DisplaySignatures(overloads,display_arg))
+		raise_signatures overloads display_arg
 	in
 	let find_constructor_types t = match follow t with
 		| TInst (c,tl) | TAbstract({a_impl = Some c},tl) ->
@@ -163,7 +164,7 @@ and display_expr ctx e_ast e dk with_type p =
 			| _ -> e.etype,None
 		in
 		let t,doc = loop e in
-		raise (Display.DisplayType (t,p,doc))
+		raise_type t p doc
 	| DMUsage _ ->
 		let rec loop e = match e.eexpr with
 		| TField(_,FEnum(_,ef)) ->
@@ -232,12 +233,12 @@ and display_expr ctx e_ast e dk with_type p =
 			[]
 		in
 		let pl = loop e in
-		raise (Display.DisplayPosition pl);
+		raise_position pl
 	| DMDefault when not (!Parser.had_resume)->
-		raise (Display.DisplayFields (DisplayToplevel.collect ctx false with_type,true))
+		raise_fields (DisplayToplevel.collect ctx false with_type) true
 	| DMDefault | DMNone | DMModuleSymbols _ | DMDiagnostics _ | DMStatistics ->
 		let fields = DisplayFields.collect ctx e_ast e dk with_type p in
-		raise (Display.DisplayFields(fields,false))
+		raise_fields fields false
 
 let handle_structure_display ctx e fields =
 	let p = pos e in
@@ -247,10 +248,10 @@ let handle_structure_display ctx e fields =
 			if Expr.field_mem_assoc k fl then acc
 			else (DisplayTypes.CompletionKind.ITClassMember cf) :: acc
 		) fields [] in
-		raise (Display.DisplayFields(fields,false))
+		raise_fields fields false
 	| EBlock [] ->
 		let fields = PMap.foldi (fun _ cf acc -> DisplayTypes.CompletionKind.ITClassMember cf :: acc) fields [] in
-		raise (Display.DisplayFields(fields,false))
+		raise_fields fields false
 	| _ ->
 		error "Expected object expression" p