From 27d47c313b69a5050b6998ecc0cf103619fe7b91 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Je=CC=81ro=CC=82me=20FERET?= Date: Sun, 7 May 2023 07:40:23 +0200 Subject: [PATCH] #661 filter out KaSa messages for UI --- core/api/api_common.ml | 4 +- core/error_handlers/exception.ml | 26 +++++++------ core/error_handlers/exception.mli | 8 ++-- .../parameters/exception_without_parameter.ml | 38 ++++++++++++++++++- .../exception_without_parameter.mli | 4 +- 5 files changed, 59 insertions(+), 21 deletions(-) diff --git a/core/api/api_common.ml b/core/api/api_common.ml index 9084ecb870..6ec0997390 100644 --- a/core/api/api_common.ml +++ b/core/api/api_common.ml @@ -27,8 +27,8 @@ let result_error_exception result_error_msg ?severity ?result_code message let method_handler_errors ?severity mh = - let uncaught = Exception_without_parameter.get_uncaught_exception_list mh in - let caught = Exception_without_parameter.get_caught_exception_list mh in + let uncaught = Exception_without_parameter.get_uncaught_exception_list_to_ui mh in + let caught = Exception_without_parameter.get_caught_exception_list_to_ui mh in List.fold_right (fun x l -> error_msg ?severity diff --git a/core/error_handlers/exception.ml b/core/error_handlers/exception.ml index 807298289c..3af8b5c464 100644 --- a/core/error_handlers/exception.ml +++ b/core/error_handlers/exception.ml @@ -28,20 +28,21 @@ let safe_warn parameters _error_handler file_name message exn _default = let _ = Loggers.print_newline (Remanent_parameters.get_logger parameters) in raise (Exception_without_parameter.Uncaught_exception uncaught) -let unsafe_warn _parameters error_handler file_name message exn default = +let unsafe_warn + _parameters error_handler ?to_ui file_name message exn default = let uncaught = Exception_without_parameter.build_uncaught_exception ?file_name ?message exn in - Exception_without_parameter.add_uncaught_error uncaught error_handler, default () + Exception_without_parameter.add_uncaught_error uncaught ?to_ui error_handler, default () -let warn_aux parameters error_handler file message exn default = +let warn_aux parameters error_handler ?to_ui file message exn default = let error,dft = if Remanent_parameters.get_unsafe parameters - then unsafe_warn parameters error_handler file message exn default + then unsafe_warn parameters error_handler ?to_ui file message exn default else safe_warn parameters error_handler file message exn default in let () = Remanent_parameters.save_error_list parameters error in error,dft -let warn_with_exn parameters error_handler (file,line,_,_) ?message:(message="") ?pos:(pos=None) exn default = +let warn_with_exn parameters error_handler ?to_ui (file,line,_,_) ?message:(message="") ?pos:(pos=None) exn default = let liaison = if message = "" && pos = None then "" else ": " in let pos = match pos with @@ -49,12 +50,12 @@ let warn_with_exn parameters error_handler (file,line,_,_) ?message:(message="") | Some s -> ", "^Locality.to_string s in warn_aux - parameters error_handler + parameters error_handler ?to_ui (Some file) (Some ("line "^(string_of_int line)^pos^liaison^message)) exn default -let warn parameters error_handler file_line ?message:(message="") ?pos exn default = - warn_with_exn parameters error_handler file_line ~message ~pos exn (fun () -> default) +let warn parameters error_handler ?to_ui file_line ?message:(message="") ?pos exn default = + warn_with_exn parameters error_handler ?to_ui file_line ~message ~pos exn (fun () -> default) let print_for_KaSim parameters handlers = let parameters = Remanent_parameters.update_prefix parameters "error: " in @@ -116,11 +117,12 @@ let _lift_error_logs_for_KaSa f = string_opt exn (fun () -> ()))) let check_point - (warn:Remanent_parameters_sig.parameters -> method_handler -> 'a -> ?message:string -> ?pos:Locality.t -> - exn -> unit -> method_handler * unit) - parameter error error' s ?message ?pos exn = + (warn:Remanent_parameters_sig.parameters -> method_handler + -> ?to_ui:bool -> 'a -> ?message:string -> ?pos:Locality.t + -> exn -> unit -> method_handler * unit) + parameter error error' s ?to_ui ?message ?pos exn = if error==error' then error else - let error,() = warn parameter error' s ?message ?pos exn () in + let error,() = warn parameter error' ?to_ui s ?message ?pos exn () in error diff --git a/core/error_handlers/exception.mli b/core/error_handlers/exception.mli index bfd76c7334..d0d074357a 100644 --- a/core/error_handlers/exception.mli +++ b/core/error_handlers/exception.mli @@ -6,12 +6,12 @@ val empty_error_handler : method_handler val is_empty_error_handler : method_handler -> bool val warn_with_exn : - Remanent_parameters_sig.parameters -> method_handler -> + Remanent_parameters_sig.parameters -> method_handler -> ?to_ui:bool -> string * int * int * int -> ?message:string -> ?pos:Locality.t option -> exn -> (unit -> 'a) -> method_handler * 'a val warn : - Remanent_parameters_sig.parameters -> method_handler -> + Remanent_parameters_sig.parameters -> method_handler -> ?to_ui:bool -> string * int * int * int -> ?message:string -> ?pos:Locality.t -> exn -> 'a -> method_handler * 'a @@ -23,7 +23,7 @@ val wrap : Remanent_parameters_sig.parameters -> method_handler -> string -> string option -> exn -> method_handler val check_point : - (Remanent_parameters_sig.parameters -> method_handler -> 'a -> ?message:string -> ?pos:Locality.t -> + (Remanent_parameters_sig.parameters -> method_handler -> ?to_ui:bool -> 'a -> ?message:string -> ?pos:Locality.t -> exn -> unit -> method_handler * unit) -> Remanent_parameters_sig.parameters -> method_handler -> method_handler -> - 'a -> ?message:string -> ?pos:Locality.t -> exn -> method_handler + 'a -> ?to_ui:bool -> ?message:string -> ?pos:Locality.t -> exn -> method_handler diff --git a/core/parameters/exception_without_parameter.ml b/core/parameters/exception_without_parameter.ml index 3451c916d2..767a8330d7 100644 --- a/core/parameters/exception_without_parameter.ml +++ b/core/parameters/exception_without_parameter.ml @@ -275,7 +275,9 @@ and stringlist_of_caught_light x stack = type method_handler = { mh_caught_error_list:caught_exception list; + mh_caught_error_list_to_ui:caught_exception list; mh_uncaught_error_list:uncaught_exception list; + mh_uncaught_error_list_to_ui:uncaught_exception list; } let to_json method_handler = @@ -284,9 +286,16 @@ let to_json method_handler = "caught", JsonUtil.of_list caught_exception_to_json method_handler.mh_caught_error_list; + "caught", + JsonUtil.of_list + caught_exception_to_json method_handler.mh_caught_error_list_to_ui; "uncaught", JsonUtil.of_list uncaught_exception_to_json method_handler.mh_uncaught_error_list; + "uncaught_to_ui", + JsonUtil.of_list + uncaught_exception_to_json method_handler.mh_uncaught_error_list_to_ui; + ] let of_json = @@ -298,13 +307,23 @@ let of_json = (JsonUtil.to_list caught_exception_of_json) (List.assoc "caught" l) in + let caught_to_ui = + (JsonUtil.to_list caught_exception_of_json) + (List.assoc "caught_to_ui" l) + in let uncaught = (JsonUtil.to_list uncaught_exception_of_json) (List.assoc "uncaught" l) in + let uncaught_to_ui = + (JsonUtil.to_list uncaught_exception_of_json) + (List.assoc "uncaught_to_ui" l) + in { mh_caught_error_list = caught ; + mh_caught_error_list_to_ui = caught_to_ui ; mh_uncaught_error_list = uncaught ; + mh_uncaught_error_list_to_ui = uncaught_to_ui ; } with | _ -> @@ -317,12 +336,27 @@ let of_json = let empty_error_handler = { mh_caught_error_list=[]; + mh_caught_error_list_to_ui=[]; mh_uncaught_error_list=[]; + mh_uncaught_error_list_to_ui=[]; } -let add_uncaught_error uncaught error = {error with mh_uncaught_error_list = uncaught::error.mh_uncaught_error_list} +let add_uncaught_error_to_ui uncaught error = {error with mh_uncaught_error_list_to_ui = uncaught::error.mh_uncaught_error_list_to_ui} +let add_uncaught_error_to_others uncaught error = {error with mh_uncaught_error_list = uncaught::error.mh_uncaught_error_list} + +let add_uncaught_error ?to_ui uncaught error = + let error = + match to_ui with + | Some false | None -> error + | Some true -> add_uncaught_error_to_ui uncaught error + in + add_uncaught_error_to_others uncaught error + + + let get_caught_exception_list error = error.mh_caught_error_list +let get_caught_exception_list_to_ui error = error.mh_caught_error_list_to_ui let get_uncaught_exception_list error = error.mh_uncaught_error_list - +let get_uncaught_exception_list_to_ui error = error.mh_uncaught_error_list_to_ui let is_empty_error_handler x = x.mh_caught_error_list=[] && x.mh_uncaught_error_list=[] diff --git a/core/parameters/exception_without_parameter.mli b/core/parameters/exception_without_parameter.mli index b37c02f860..9b4de84233 100644 --- a/core/parameters/exception_without_parameter.mli +++ b/core/parameters/exception_without_parameter.mli @@ -24,7 +24,7 @@ type method_handler val raise_exception: string option -> unit -> string option -> exn -> unit val build_uncaught_exception: ?file_name:string -> ?message:string -> exn -> uncaught_exception val build_caught_exception: string option -> string option -> exn -> string list -> caught_exception -val add_uncaught_error: uncaught_exception -> method_handler -> method_handler +val add_uncaught_error: ?to_ui:bool -> uncaught_exception -> method_handler -> method_handler val stringlist_of_exception: exn -> string list -> string list val stringlist_of_uncaught: uncaught_exception -> string list -> string list val stringlist_of_caught: caught_exception -> string list -> string list @@ -38,7 +38,9 @@ val empty_error_handler: method_handler val is_empty_error_handler: method_handler -> bool val get_caught_exception_list: method_handler -> caught_exception list +val get_caught_exception_list_to_ui: method_handler -> caught_exception list val get_uncaught_exception_list: method_handler -> uncaught_exception list +val get_uncaught_exception_list_to_ui: method_handler -> uncaught_exception list val to_json: method_handler -> Yojson.Basic.t val of_json: Yojson.Basic.t -> method_handler