Fix overly-wide exception catches that swallow Cancelled and JsonCompleted

Co-authored-by: Simn <634365+Simn@users.noreply.github.com>

Author: Copilot

src/compiler/compiler.ml

@@ -447,7 +447,7 @@ with
 		error com ("Error: No completion point was found") null_pos
 	| DisplayException.DisplayException dex ->
 		DisplayOutput.handle_display_exception com dex
-	| CompilerMessage.Abort | Out_of_memory | EvalTypes.Sys_exit _ | Hlinterp.Sys_exit _ | DisplayJson.JsonCompleted as exc ->
+	| CompilerMessage.Abort | Out_of_memory | EvalTypes.Sys_exit _ | Hlinterp.Sys_exit _ | DisplayJson.JsonCompleted | Globals.Cancelled as exc ->
 		(* We don't want these to be caught by the catchall below *)
 		raise exc
 	| e when (try Sys.getenv "OCAMLRUNPARAM" <> "b" with _ -> true) && not Helper.is_debug_run ->

src/compiler/displayProcessing.ml

@@ -135,7 +135,7 @@ let load_display_module_in_macro tctx display_file_dot_path clear = match displa
 			let _ = MacroContext.load_macro_module (MacroContext.get_macro_context tctx) tctx.com cpath true p in
 			Finalization.finalize mctx;
 			Some mctx
-		with DisplayException.DisplayException _ | Parser.TypePath _ as exc ->
+		with DisplayException.DisplayException _ | Parser.TypePath _ | Globals.Cancelled | DisplayJson.JsonCompleted as exc ->
 			raise exc
 		| _ ->
 			None

src/context/commonCache.ml

@@ -15,7 +15,8 @@ class lib_build_task cs file ftime lib = object(self)
 				try begin match lib#build path p with
 				| Some r -> Hashtbl.add h path r
 				| None -> ()
-				end with _ ->
+				end with Globals.Cancelled as e -> raise e
+				| _ ->
 					()
 			end
 		) lib#list_modules;

src/context/display/display.ml

@@ -90,5 +90,6 @@ let get_import_status ctx path =
 	try
 		let mt' = ctx.g.do_load_type_def ctx null_pos (mk_type_path ([],snd path)) in
 		if path <> (t_infos mt').mt_path then Shadowed else Imported
-	with _ ->
+	with Globals.Cancelled as e -> raise e
+	| _ ->
 		Unimported

src/context/display/displayFields.ml

@@ -381,7 +381,8 @@ let handle_missing_field_raise ctx tthis i mode with_type pfield =
 					begin try
 						let e = type_expr ctx e WithType.value in
 						e.etype
-					with _ ->
+					with Globals.Cancelled as e -> raise e
+					| _ ->
 						mk_mono()
 					end
 				| _ -> mk_mono()
@@ -393,7 +394,8 @@ let handle_missing_field_raise ctx tthis i mode with_type pfield =
 				begin try
 					let e = type_expr ctx e WithType.value in
 					e.etype
-				with _ ->
+				with Globals.Cancelled as e -> raise e
+				| _ ->
 					raise Exit
 				end
 			| _ -> raise Exit
@@ -410,7 +412,8 @@ let handle_missing_field_raise ctx tthis i mode with_type pfield =
 					(name,false,e.etype)
 				) el in
 				(TFun(tl,tret),Method MethNormal)
-			with _ ->
+			with Globals.Cancelled as e -> raise e
+			| _ ->
 				raise Exit
 			end
 		| MGet ->

src/context/display/displayPath.ml

@@ -155,7 +155,9 @@ module TypePathHandler = struct
 				) en.e_constrs fields
 			in
 			Some fields
-		with _ ->
+		with Globals.Cancelled | DisplayException.DisplayException _ | Parser.TypePath _ as e ->
+			raise e
+		| _ ->
 			Error.abort ("Could not load module " ^ (s_type_path (p,c))) null_pos
 end
 

src/context/display/displayToplevel.ml

@@ -49,7 +49,8 @@ let maybe_resolve_macro_field ctx t c cf =
 		let (tl,tr,c,cf) = ctx.g.do_load_macro ctx false c.cl_path cf.cf_name null_pos in
 		let t = perform_type_voodoo t tl tr in
 		t,{cf with cf_type = t}
-	with _ ->
+	with Globals.Cancelled as e -> raise e
+	| _ ->
 		t,cf
 
 let exclude : string list ref = ref []
@@ -157,7 +158,7 @@ let init_or_update_server cs com timer_name =
 		try
 			ignore(cc#find_file file_key);
 		with Not_found ->
-			try ignore(TypeloadParse.parse_module_file com file_path null_pos) with _ -> ()
+			try ignore(TypeloadParse.parse_module_file com file_path null_pos) with Globals.Cancelled as e -> raise e | _ -> ()
 	) removed_files;
 	DynArray.iter (Hashtbl.remove removed_files) removed_removed_files
 

src/context/display/syntaxExplorer.ml

@@ -179,7 +179,8 @@ let explore_uncached_modules tctx cs symbols =
 					(* We have to flush immediately so we catch exceptions from weird modules *)
 					Typecore.flush_pass tctx.g PFinal ("final",cfile.c_package @ [module_name]);
 					m :: acc
-				with _ ->
+				with Globals.Cancelled as e -> raise e
+				| _ ->
 					acc
 				end
 		) files []

src/typing/macroContext.ml

@@ -102,7 +102,8 @@ let make_macro_com_api com mcom p =
 			match ParserEntry.parse_string (ParserConfig.default_config com.defines) Grammar.parse_meta s null_pos raise_typing_error false with
 			| ParseSuccess(meta,_) -> meta
 			| ParseError(_,_,_) -> raise_typing_error "Malformed metadata string" p
-		with _ ->
+		with Globals.Cancelled as e -> raise e
+		| _ ->
 			raise_typing_error "Malformed metadata string" p
 	in
 	let bad_stage () =
@@ -311,7 +312,8 @@ let make_macro_api ctx mctx p =
 			match ParserEntry.parse_string (ParserConfig.default_config mctx.com.defines) Grammar.parse_meta s null_pos raise_typing_error false with
 			| ParseSuccess(meta,_) -> meta
 			| ParseError(_,_,_) -> raise_typing_error "Malformed metadata string" p
-		with _ ->
+		with Globals.Cancelled as e -> raise e
+		| _ ->
 			raise_typing_error "Malformed metadata string" p
 	in
 	let com_api = make_macro_com_api ctx.com mctx.com p in

src/typing/typerDisplay.ml

@@ -29,7 +29,8 @@ let completion_item_of_expr ctx e =
 		try
 			let e' = type_expr ctx (EConst(Ident s),null_pos) (WithType.with_type t) in
 			Texpr.equal e e'
-		with _ ->
+		with Globals.Cancelled as e -> raise e
+		| _ ->
 			false
 	in
 	let tpair ?(values=PMap.empty) t =
@@ -581,7 +582,8 @@ let filter_ctors ctx r =
 						| _ -> false)
 					| _ -> false
 					end
-				with _ ->
+				with Globals.Cancelled as e -> raise e
+				| _ ->
 					false
 				end
 			end