| 1 | | % (c) 2009-2023 Lehrstuhl fuer Softwaretechnik und Programmiersprachen, |
| 2 | | % Heinrich Heine Universitaet Duesseldorf |
| 3 | | % This software is licenced under EPL 1.0 (http://www.eclipse.org/org/documents/epl-v10.html) |
| 4 | | |
| 5 | | :- module(self_check, |
| 6 | | [assert_pre/2, assert_post/2,pp_mnf/1, pp_cll/1, mnf/1, mnf/2, |
| 7 | | mnf_det/1, det_call/1, force_det_call/1, |
| 8 | | assert_must_succeed/1,assert_must_fail/1, |
| 9 | | assert_must_succeed_multiple/1, assert_must_succeed_any/1, |
| 10 | | must_fail/1, must_succeed/1, must_succeed_without_residue/1, |
| 11 | | must_succeed_without_residue_and_time_out/1, |
| 12 | | |
| 13 | | run_time_type_check_mode/1, |
| 14 | | turn_on_run_time_type_checks/0,turn_off_run_time_type_checks/0, |
| 15 | | |
| 16 | | get_module_list/1, |
| 17 | | |
| 18 | | perform_self_check/0, perform_self_check/1, perform_self_check/2, |
| 19 | | perform_verbose_self_check/0, perform_verbose_self_check/1, |
| 20 | | portray_self_checks/0, |
| 21 | | |
| 22 | | disable_interaction_on_errors/0, |
| 23 | | |
| 24 | | % time_out_call/2, time_out_with_factor_call/3, time_out_call/1, % now in tools_timeout |
| 25 | | |
| 26 | | check_deterministic/1, check_det/1, |
| 27 | | |
| 28 | | list_skeleton/1, |
| 29 | | |
| 30 | | self_checks_exist/0, |
| 31 | | check_eq/2, |
| 32 | | check_eqeq/2 |
| 33 | | |
| 34 | | ]). |
| 35 | | |
| 36 | | :- meta_predicate nonvar_call(0). |
| 37 | | :- meta_predicate assert_post(0,0). |
| 38 | | :- meta_predicate(get_call_module(0, *)). |
| 39 | | :- meta_predicate assert_must_succeed_any(0). |
| 40 | | :- meta_predicate assert_must_succeed(0). |
| 41 | | :- meta_predicate assert_must_succeed_multiple(0). |
| 42 | | :- meta_predicate assert_must_fail(0). |
| 43 | | %:- meta_predicate kernel_waitflags:assert_must_abort_wf(0,*). |
| 44 | | :- meta_predicate pp_mnf(0), pp_cll(0), mnf(0), mnf(-,0), det_call(0). |
| 45 | | :- meta_predicate mnf_call(0), mnf_call_with_pp(-,0), prepost_mnf_call(0). |
| 46 | | :- meta_predicate prepost_call(0). |
| 47 | | :- meta_predicate check_exception_call(0). |
| 48 | | :- meta_predicate rt_timeout_call(0). |
| 49 | | :- meta_predicate mnf_det(0). |
| 50 | | :- meta_predicate force_det_call(0). |
| 51 | | :- meta_predicate residue_check_call(0). |
| 52 | | :- meta_predicate must_fail(0). |
| 53 | | :- meta_predicate must_succeed(0). |
| 54 | | :- meta_predicate must_succeed_without_residue_and_time_out(0). |
| 55 | | :- meta_predicate must_succeed_without_residue(0). |
| 56 | | :- meta_predicate must_succeed_multiple_without_residue(0). |
| 57 | | :- meta_predicate safe_call(0). |
| 58 | | :- meta_predicate check_deterministic(0). |
| 59 | | :- meta_predicate check_det(0). |
| 60 | | :- meta_predicate check_det2(0,-). |
| 61 | | |
| 62 | | :- use_module(debugging_calls). |
| 63 | | %:- disable_debugging_calls. |
| 64 | | |
| 65 | | :- use_module(module_information,[module_info/2]). |
| 66 | | :- module_info(group,testing). |
| 67 | | :- module_info(description,'This module provides predicates to define and run unit tests.'). |
| 68 | | |
| 69 | | :- use_module(tools_printing,[format_with_colour/4, print_goal/1]). |
| 70 | | |
| 71 | | % first code which asserts pre-, post-conditions and self-checks |
| 72 | | |
| 73 | | % first a copy of print_error; so that this bit of self-check does not rely on other modules |
| 74 | | my_print_error(Error) :- |
| 75 | | (var(Error) |
| 76 | | -> print_message(error,'_') |
| 77 | | ; write(user_error,'! '),write_term(user_error,Error,[max_depth(50),numbervars(true)]),nl(user_error) |
| 78 | | ). |
| 79 | | |
| 80 | | my_portray_error(Query) :- safe_numbervars(Query,0,_), |
| 81 | | write_term(user_error,Query,[portrayed(true),numbervars(true),max_depth(50),indented(true)]),fail. |
| 82 | | my_portray_error(_). |
| 83 | | %my_portray_error(Query) :- portray_clause(user_error,Query). % goes into loop for cyclic terms |
| 84 | | |
| 85 | | :- dynamic pre_condition/2, post_condition/2. |
| 86 | | :- meta_predicate assert_pre(0,0). |
| 87 | | assert_pre(X,Pre) :- % print(adding_pre(X)),nl, |
| 88 | | (nonvar_call(X),nonvar_call(Pre) |
| 89 | | -> retractall(pre_condition(X,_)),assertz(pre_condition(X,Pre)) |
| 90 | | ; my_print_error('### illegal variable(s) in: '), |
| 91 | | my_print_error(assert_pre(X,Pre)),fail |
| 92 | | ). |
| 93 | | assert_post(X,Post) :- |
| 94 | | (nonvar_call(X),nonvar_call(Post) |
| 95 | | -> retractall(post_condition(X,_)),assertz(post_condition(X,Post)) |
| 96 | | ; my_print_error('### illegal variable(s) in: '), |
| 97 | | my_print_error(assert_post(X,Post)),fail |
| 98 | | ). |
| 99 | | |
| 100 | | nonvar_call(Call) :- |
| 101 | | nonvar(Call), |
| 102 | | (Call = M:P -> nonvar(M), nonvar(P) ; true). |
| 103 | | |
| 104 | | :- dynamic self_check/4. |
| 105 | | :- dynamic self_check_module/2. |
| 106 | | :- volatile self_check/4, self_check_module/2. % this means that self-check cannot be run in the compiled versions ! |
| 107 | | |
| 108 | | self_check_module(Module) :- self_check_module(Module,_NrTests). |
| 109 | | |
| 110 | | % increase number of tests for a module and return new number as id |
| 111 | | inc_self_check_module(Module,Res) :- |
| 112 | | (retract(self_check_module(Module,N1)) -> true ; N1=0), |
| 113 | | Nr is N1+1, |
| 114 | | assertz(self_check_module(Module,Nr)), |
| 115 | | Res = Nr. |
| 116 | | |
| 117 | | % used to check if there are self checks. if not, tcl/tk interface does not show the button |
| 118 | | self_checks_exist :- self_check(_,_,_,_). |
| 119 | | |
| 120 | | % has a strange behaviour; investigate :- meta_predicate self_check(:,*). |
| 121 | | |
| 122 | ? | self_check(X,Module) :- self_check(X,Module,_,_). |
| 123 | | |
| 124 | | :- load_files(library(system), [when(compile_time), imports([environ/2])]). |
| 125 | | :- if(environ(prob_release,true)). |
| 126 | | add_self_check(_,_) :- !. % comment in to not include self-checks in distribution |
| 127 | | :- endif. |
| 128 | | add_self_check(Module,X) :- |
| 129 | | (nonvar(X) -> |
| 130 | ? | (self_check(X,Module) -> true |
| 131 | | ; inc_self_check_module(Module,Nr), |
| 132 | | get_current_term_position(Line,_Col), |
| 133 | | assertz(self_check(X,Module,Nr,Line)) |
| 134 | | ) |
| 135 | | ; |
| 136 | | my_print_error('### trying to assert variable as self_check: '),my_print_error(X),fail |
| 137 | | ). |
| 138 | | |
| 139 | | get_current_term_position(Line,Col) :- |
| 140 | | %prolog_load_context(file, File), |
| 141 | | prolog_load_context(term_position,TPos), |
| 142 | | !, |
| 143 | | (stream_position_data(line_count,TPos,LineM1) -> Line is LineM1+1 ; Line='?'), |
| 144 | | (stream_position_data(line_position,TPos,Col) -> true ; Col='?'). |
| 145 | | get_current_term_position('?','?'). |
| 146 | | |
| 147 | | |
| 148 | | :- if(predicate_property(current_logtalk_flag(_, _), _)). |
| 149 | | get_call_module(_, Module) :- |
| 150 | | sender(Module). |
| 151 | | :- else. |
| 152 | | get_call_module(Module:_, Module). |
| 153 | | :- endif. |
| 154 | | |
| 155 | | assert_must_succeed_any(Call) :- |
| 156 | | get_call_module(Call,M), |
| 157 | | add_self_check(M,must_succeed(Call)). |
| 158 | | assert_must_succeed(Call) :- |
| 159 | | get_call_module(Call,M), |
| 160 | | add_self_check(M,must_succeed_without_residue(Call)). |
| 161 | | assert_must_succeed_multiple(Call) :- |
| 162 | | get_call_module(Call,M), |
| 163 | | add_self_check(M,must_succeed_multiple_without_residue(Call)). |
| 164 | | assert_must_fail(Call) :- |
| 165 | | get_call_module(Call,M), |
| 166 | | add_self_check(M,must_fail(Call)). |
| 167 | | |
| 168 | | |
| 169 | | % ------------------------ |
| 170 | | |
| 171 | | :- use_module(debug). |
| 172 | | :- use_module(tools_printing). |
| 173 | | :- use_module(error_manager). |
| 174 | | :- use_module(junit_tests). |
| 175 | | :- use_module(library(lists)). |
| 176 | | :- use_module(tools_meta,[call_residue/2,safe_numbervars/3]). |
| 177 | | |
| 178 | | /* Example use: |
| 179 | | |
| 180 | | :- assert_pre(user:b_fd_type(_G,_L,_U),true). |
| 181 | | :- assert_post(user:b_fd_type(G,L,U),(atomic(G),(integer(L),integer(U)))). |
| 182 | | |
| 183 | | */ |
| 184 | | |
| 185 | | |
| 186 | | |
| 187 | | /* some auxilary predicates that can be used for pre,post conditions: */ |
| 188 | | |
| 189 | | % used in some pre- and post-conditions |
| 190 | | list_skeleton(X) :- |
| 191 | | (nonvar(X),list_skel2(X) -> true |
| 192 | | ; (my_print_error('### not list skeleton: '), my_print_error(X),fail)). |
| 193 | | list_skel2([]). |
| 194 | | list_skel2([_H|T]) :- nonvar(T), list_skel2(T). |
| 195 | | |
| 196 | | |
| 197 | | |
| 198 | | :- dynamic run_time_type_check_mode/1. |
| 199 | | run_time_type_check_mode(on). |
| 200 | | |
| 201 | | turn_on_run_time_type_checks :- |
| 202 | | retract(run_time_type_check_mode(_)), |
| 203 | | assertz(run_time_type_check_mode(on)). |
| 204 | | |
| 205 | | turn_off_run_time_type_checks :- |
| 206 | | retract(run_time_type_check_mode(_)), |
| 207 | | assertz(run_time_type_check_mode(off)). |
| 208 | | |
| 209 | | |
| 210 | | /* ===================================================== */ |
| 211 | | |
| 212 | | :- dynamic prepost_no_error_so_far/0. |
| 213 | | |
| 214 | | prepost_no_error_so_far. % :- fail. |
| 215 | | /* as errors are now displayed by error_manager, no need for interaction ?? */ |
| 216 | | |
| 217 | | disable_interaction_on_errors :- |
| 218 | | retractall(prepost_no_error_so_far). |
| 219 | | |
| 220 | | |
| 221 | | /* ===================================================== */ |
| 222 | | |
| 223 | | :- register_debugging_calls([pp_mnf(*), pp_cll(*), mnf(*), mnf(-,*), det_call(*)]). |
| 224 | | |
| 225 | | pp_mnf(X) :- prepost_mnf_call(X). |
| 226 | | pp_cll(X) :- prepost_call(X). |
| 227 | | mnf(X) :- mnf_call(X). |
| 228 | | mnf(ProgramPoint,X) :- mnf_call_with_pp(ProgramPoint,X). |
| 229 | | |
| 230 | | |
| 231 | | /* ===================================================== */ |
| 232 | | |
| 233 | | |
| 234 | | :- use_module(library(timeout)). |
| 235 | | |
| 236 | | rt_timeout_call(Call) :- run_time_type_check_mode(off),!,check_exception_call(Call). |
| 237 | | rt_timeout_call(Call) :- time_out(check_exception_call(Call),5000,TimeOutRes), |
| 238 | | (TimeOutRes = success -> true ; inc_error_count, add_error(self_check,'### TIMEOUT: ',Call),fail). |
| 239 | | |
| 240 | | % just catch exceptions and print them nicely |
| 241 | | check_exception_call(X) :- |
| 242 | | catch(call(X), Error, ( |
| 243 | | format_with_colour(user_error,[red,bold],'! *** EXCEPTION *** :~n',[]), |
| 244 | | write('! '),print_numbervars(X),nl, |
| 245 | | write_exception_error(Error),nl, |
| 246 | | throw(Error) |
| 247 | | )). |
| 248 | | |
| 249 | | write_exception_error(error(existence_error(procedure,CALL),_)) :- |
| 250 | | format_with_colour(user_error,[red,bold],'! EXISTENCE ERROR: ~w~n',[CALL]),fail. |
| 251 | | write_exception_error(Error) :- write('! '),write_term(Error,[max_depth(20),numbervars(true)]),nl. |
| 252 | | |
| 253 | | print_numbervars(X) :- safe_numbervars(X,0,_), print(X),fail. |
| 254 | | print_numbervars(_). |
| 255 | | |
| 256 | | prepost_call(X) :- |
| 257 | | /* print(pre(X)),nl, */ |
| 258 | | (verify_pre(X) -> true ; my_print_error(verify_pre_failed(X))), |
| 259 | | rt_timeout_call(X), |
| 260 | | /* print(post(X)),nl, */ |
| 261 | | (verify_post(X) -> true ; my_print_error(verify_post_failed(X))). |
| 262 | | |
| 263 | | verify_pre(Call) :- |
| 264 | | (run_time_type_check_mode(off) -> true |
| 265 | | ; pre_condition(Call,Pre) -> |
| 266 | | ( \+ rt_timeout_call(Pre) |
| 267 | | -> get_predicate_arity(Call,Pred,Arity), |
| 268 | | add_error(verify_pre,'### PRE-CONDITION ERROR OCCURRED: ',Pred/Arity), |
| 269 | | add_error(verify_pre,'### CALL: ',Call),nl, |
| 270 | | prepost_user_interaction |
| 271 | | ; true |
| 272 | | ) |
| 273 | | ; get_predicate_arity(Call,Pred,Arity), |
| 274 | | add_error(verify_pre,'### No PRE-CONDITION for ',Pred/Arity), |
| 275 | | print_term_summary(Call), |
| 276 | | prepost_user_interaction |
| 277 | | ). |
| 278 | | |
| 279 | | verify_post(Call) :- |
| 280 | | (run_time_type_check_mode(off) -> true |
| 281 | | ; post_condition(Call,Post) -> |
| 282 | | ( \+ rt_timeout_call(Post) |
| 283 | | -> get_predicate_arity(Call,Pred,Arity), |
| 284 | | add_error(verify_post,'### POST-CONDITION ERROR OCCURRED: ',Pred/Arity), |
| 285 | | add_error(verify_post,'### CALL: ',Call),nl, |
| 286 | | prepost_user_interaction |
| 287 | | ; true |
| 288 | | ) |
| 289 | | ; get_predicate_arity(Call,Pred,Arity), |
| 290 | | add_error(verify_post,'### No POST-CONDITION for ',Pred/Arity), |
| 291 | | prepost_user_interaction |
| 292 | | ). |
| 293 | | |
| 294 | | |
| 295 | | prepost_user_interaction :- prepost_no_error_so_far,!, |
| 296 | | my_print_error('### => Stop at next error (y/n/halt/trace) => '), |
| 297 | | read(Answer), |
| 298 | | (Answer='y' -> true |
| 299 | | ; Answer='halt' -> halt |
| 300 | | ; Answer='trace' -> trace |
| 301 | | ; retract(prepost_no_error_so_far)). |
| 302 | | prepost_user_interaction. |
| 303 | | |
| 304 | | |
| 305 | | get_predicate_arity(':'(Module,Call),Res,Arity) :- !,Res=Module:Pred, |
| 306 | | functor(Call,Pred,Arity). |
| 307 | | get_predicate_arity(Call,Pred,Arity) :- |
| 308 | | functor(Call,Pred,Arity). |
| 309 | | |
| 310 | | /* ===================================================== */ |
| 311 | | |
| 312 | | prepost_mnf_call(X) :- % print(prepost_mnf_call(X)),nl, |
| 313 | | (run_time_type_check_mode(off) |
| 314 | | -> call(X) |
| 315 | | ; if(prepost_call(X),true, |
| 316 | | (add_error(mnf,'### WARNING CALL HAS FAILED: ',X), |
| 317 | | print_call(X), |
| 318 | | prepost_user_interaction, |
| 319 | | fail) |
| 320 | | ) |
| 321 | | ). |
| 322 | | |
| 323 | | mnf_call(X) :- |
| 324 | | (run_time_type_check_mode(off) |
| 325 | | -> call(X) |
| 326 | | ; if(call(X),true, |
| 327 | | (add_error(mnf,'### WARNING CALL HAS FAILED: ',X), |
| 328 | | print_call(X), |
| 329 | | prepost_user_interaction, |
| 330 | | fail) |
| 331 | | ) |
| 332 | | ). |
| 333 | | |
| 334 | | print_call(X) :- |
| 335 | | print('### Call: '),print_quoted_with_max_depth(X,10),nl, |
| 336 | | print('### Summary: '),print_term_summary(X),nl, |
| 337 | | print('### Predicate: '), |
| 338 | | (X = ':'(M,C) -> (print(M),print(':')) ; C=X), |
| 339 | | functor(C,F,N), |
| 340 | | print(F), print('/'), print(N),nl. |
| 341 | | |
| 342 | | |
| 343 | | mnf_call_with_pp(ProgramPoint,X) :- |
| 344 | | (run_time_type_check_mode(off) |
| 345 | | -> call(X) |
| 346 | | ; if(rt_timeout_call(X),true, |
| 347 | | (add_error(mnf,'### WARNING CALL HAS FAILED: ',(X,ProgramPoint)), |
| 348 | | print_call(X), |
| 349 | | print('### at program point:'),print(ProgramPoint),nl, |
| 350 | | prepost_user_interaction, |
| 351 | | fail) |
| 352 | | ) |
| 353 | | ). |
| 354 | | |
| 355 | | :- volatile found_det_sol/4. |
| 356 | | :- dynamic found_det_sol/4. |
| 357 | | |
| 358 | | mnf_det(X) :- |
| 359 | | (run_time_type_check_mode(off) |
| 360 | | -> call(X) |
| 361 | | ; (get_functor_module(X,Module,F,Arity), |
| 362 | | retractall(found_det_sol(F,Arity,Module,_)), /* cannot be nested for same predicate !*/ |
| 363 | | copy_term(X,CopyX), |
| 364 | | mnf_call(X), |
| 365 | | (found_det_sol(F,Arity,Module,Previous) -> |
| 366 | | (add_error(mnf,'### WARNING CALL HAS MULTIPLE SOLUTIONS: ',CopyX),nl, |
| 367 | | print('### Solution 1: '),print_quoted_with_max_depth(Previous,60),nl,nl, |
| 368 | | print('### Solution 2: '),print_quoted_with_max_depth(X,60),nl,nl, |
| 369 | | prepost_user_interaction) |
| 370 | | ; assertz(found_det_sol(F,Arity,Module,X)) |
| 371 | | ) |
| 372 | | ) |
| 373 | | ). |
| 374 | | |
| 375 | | % det_call(';'(X=a,X=b)). |
| 376 | | get_functor_module(Module:Call,Module,F,Arity) :- !, functor(Call,F,Arity). |
| 377 | | get_functor_module(Call,unknown,F,Arity) :- functor(Call,F,Arity). |
| 378 | | |
| 379 | | det_call(X) :- |
| 380 | | (run_time_type_check_mode(off) |
| 381 | | -> call(X) |
| 382 | | ; force_det_call(X) |
| 383 | | ). |
| 384 | | |
| 385 | | residue_check_call(X) :- |
| 386 | | copy_term(X,CX), |
| 387 | | call_residue(X,CallResidue), |
| 388 | | (maplist(acceptable_residue,CallResidue) -> true |
| 389 | | ; add_error(must_succeed_without_residue,'### Call has residue: ',X), |
| 390 | | add_error(must_succeed_without_residue,'### Residue: ',CallResidue), |
| 391 | | inc_error_count, |
| 392 | | print_goal(CallResidue),nl, |
| 393 | | safe_numbervars(CX,0,_), |
| 394 | | format('### Original call: ~w~n',[CX]) |
| 395 | | ). |
| 396 | | |
| 397 | | % if we use ground_det_wait_flag: we can have these residues |
| 398 | | acceptable_residue(kernel_waitflags:copy_wfe_to_inner(_,_)). |
| 399 | | % Default representation returned by SWI for attributes from modules |
| 400 | | % that don't define attribute_goals//1. |
| 401 | | acceptable_residue(put_attr(_,_,_)). |
| 402 | | acceptable_residue((A,B)) :- acceptable_residue(A),acceptable_residue(B). |
| 403 | | |
| 404 | | force_det_call(X) :- |
| 405 | | get_functor_module(X,Module,F,Arity), |
| 406 | | retractall(found_det_sol(F,Arity,Module,_)), /* cannot be nested for same predicate !*/ |
| 407 | | copy_term(X,CopyX), |
| 408 | | %print(det_call(X)),nl, |
| 409 | | residue_check_call(X), % was rt_timeout_call(X) |
| 410 | | (found_det_sol(F,Arity,Module,Previous) -> |
| 411 | | (add_error(mnf,'### WARNING CALL HAS MULTIPLE SOLUTIONS: ',CopyX),nl, |
| 412 | | print('### Solution 1: '),print_quoted_with_max_depth(Previous,60),nl,nl, |
| 413 | | print('### Solution 2: '),print_quoted_with_max_depth(X,60),nl,nl, |
| 414 | | prepost_user_interaction) |
| 415 | | ; assertz(found_det_sol(F,Arity,Module,X)) |
| 416 | | ). |
| 417 | | |
| 418 | | /* ===================================================== */ |
| 419 | | |
| 420 | | must_fail(X) :- |
| 421 | | copy_term(X,Y), |
| 422 | | rt_timeout_call(X),!, |
| 423 | | %(safe_numbervars(Y,0,_) -> true ; true), % portray already does a numbervars |
| 424 | | inc_error_count(Module,_NrErr), |
| 425 | | add_error(must_fail,'Unit Test Failed, a call unexpectedly succeeded in module:',Module), |
| 426 | | my_print_error('! The call: '), |
| 427 | | my_portray_error(Y), |
| 428 | | my_print_error('! should have failed but succeeded with:'), |
| 429 | | my_portray_error(X). |
| 430 | | must_fail(_X). |
| 431 | | |
| 432 | | |
| 433 | | |
| 434 | | must_succeed(X) :- %print(must_suceed(X)),nl, |
| 435 | | \+ rt_timeout_call(X),!, |
| 436 | | %(safe_numbervars(X,0,_) -> true ; true), % portray already does a numbervars |
| 437 | | inc_error_count(Module,_NrErr), |
| 438 | | add_error(must_succeed,'Unit Test Failed, a call unexpectedly failed in module:',Module), |
| 439 | | my_print_error('! The call failed but should have succeeded: '), |
| 440 | | my_portray_error(X), |
| 441 | | %trace, X, % and comment out safe_numbervars above |
| 442 | | nl. |
| 443 | | must_succeed(_X). % :- print(ok_must_succeed(_X)),nl. |
| 444 | | |
| 445 | | :- volatile found_must_succeed_sol/1, found_id/1. |
| 446 | | :- dynamic found_must_succeed_sol/1, found_id/1. |
| 447 | | found_id(0). |
| 448 | | get_found_id(Nr) :- retract(found_id(Nr)), N1 is Nr+1, assertz(found_id(N1)). |
| 449 | | reset_found_id :- retractall(found_must_succeed_sol(_)), |
| 450 | | retractall(found_id(_)), assertz(found_id(0)). |
| 451 | | |
| 452 | | must_succeed_without_residue_and_time_out(X) :- |
| 453 | | time_out(check_exception_call(X),2000,TimeOutRes), |
| 454 | | (TimeOutRes = success -> true |
| 455 | | ; inc_error_count, |
| 456 | | add_error(self_check,'### TIMEOUT: ',X), portray_clause(X),nl, |
| 457 | | fail). |
| 458 | | |
| 459 | | must_succeed_without_residue(X) :- get_found_id(ID), |
| 460 | | must_succeed(residue_check_call(X)), |
| 461 | | retractall(found_must_succeed_sol(ID)), |
| 462 | | %residue_check_call(X), |
| 463 | | (found_must_succeed_sol(ID) |
| 464 | | -> add_error(must_succeed_without_residue,'### Self-Check has multiple solutions: ',X), |
| 465 | | inc_error_count, |
| 466 | | ! |
| 467 | | ; assertz(found_must_succeed_sol(ID)),fail |
| 468 | | ). |
| 469 | | must_succeed_without_residue(_). |
| 470 | | |
| 471 | | :- public must_succeed_multiple_without_residue/1. % used by assert_must_succeed_multiple |
| 472 | | must_succeed_multiple_without_residue(X) :- get_found_id(ID), |
| 473 | | must_succeed(X), |
| 474 | | retractall(found_must_succeed_sol(ID)), |
| 475 | | call_residue(X,CallResidue), |
| 476 | | (maplist(acceptable_residue,CallResidue) -> true -> true |
| 477 | | ; add_error(must_succeed_multiple_without_residue,'### Self-Check has residue: ',X), |
| 478 | | add_error(must_succeed_multiple_without_residue,'### Residue: ',CallResidue), |
| 479 | | inc_error_count, |
| 480 | | print_goal(CallResidue),nl |
| 481 | | ), |
| 482 | | (found_must_succeed_sol(ID) |
| 483 | | -> (true,!) |
| 484 | | ; assertz(found_must_succeed_sol(ID)),fail |
| 485 | | ). |
| 486 | | must_succeed_multiple_without_residue(X) :- |
| 487 | | inc_error_count, |
| 488 | | add_error(must_succeed_multiple_without_residue, |
| 489 | | '### Self-Check did not succeed multiple times: ',X). |
| 490 | | |
| 491 | | |
| 492 | | |
| 493 | | safe_call(X) :- |
| 494 | | catch(call(X), Exception, ( |
| 495 | | print(exception(X,Exception)),nl,nl, |
| 496 | | inc_error_count, |
| 497 | | add_error(safe_call,'### Exception occurred during self-check: ',X:Exception) |
| 498 | | )). |
| 499 | | |
| 500 | | :- dynamic starttime/1. |
| 501 | | |
| 502 | | get_module_list(ML) :- findall(Module,self_check_module(Module),Modules), sort(Modules,ML). |
| 503 | | |
| 504 | | |
| 505 | | |
| 506 | | |
| 507 | | :- dynamic errors_in_module/2, current_module_under_test/1, tests_in_module/2. |
| 508 | | set_current_module(M) :- var(M),!, my_print_error('Module is variable'). |
| 509 | | set_current_module(M) :- |
| 510 | | retractall(current_module_under_test(_)), |
| 511 | | assertz(current_module_under_test(M)). |
| 512 | | get_error_count(Module,Nr) :- errors_in_module(Module,Nr), !. |
| 513 | | get_error_count(_,0). |
| 514 | | inc_error_count :- inc_error_count(_,_). |
| 515 | | inc_error_count(Module,N1) :- current_module_under_test(Module),!, |
| 516 | | (retract(errors_in_module(Module,Nr)) -> true ; Nr=0), |
| 517 | | N1 is Nr+1, |
| 518 | | assertz(errors_in_module(Module,N1)). |
| 519 | | inc_error_count(unknown,1) :- print('No current module.'),nl. |
| 520 | | |
| 521 | | :- dynamic unit_test_failed_in_module/2. |
| 522 | | register_failure(Module,TestNr) :- assertz(unit_test_failed_in_module(Module,TestNr)). |
| 523 | | |
| 524 | | print_error_summary :- errors_in_module(Module,Nr), |
| 525 | | findall(TestNr,unit_test_failed_in_module(Module,TestNr),List), |
| 526 | | length(List,Len), |
| 527 | | format('Module ~w has ~w errors and ~w failed test(s): ~w.~n',[Module,Nr,Len,List]), |
| 528 | | fail. |
| 529 | | print_error_summary. |
| 530 | | |
| 531 | | print_summary :- findall(T,tests_in_module(_,T),NrTests), |
| 532 | | length(NrTests,NrModules), |
| 533 | | sumlist(NrTests,TotTests), |
| 534 | | format('Number of Unit Tests: ~w in ~w modules~n',[TotTests,NrModules]). |
| 535 | | |
| 536 | | reset_error_summary :- |
| 537 | | retractall(errors_in_module(_,_)), |
| 538 | | retractall(unit_test_failed_in_module(_,_)), |
| 539 | | retractall(tests_in_module(_,_)). |
| 540 | | |
| 541 | | run_module_tests(Module,Results,Options) :- |
| 542 | | findall(testcase(Module,TestNr,Line,X), included_self_check(X,Module,TestNr,Line,Options), Calls), |
| 543 | | length(Calls,Len), |
| 544 | | assertz(tests_in_module(Module,Len)), |
| 545 | | %maplist(check_test_case, Calls, Results). |
| 546 | | check_test_cases(Calls,Results,0,Module,Options). |
| 547 | | |
| 548 | | included_self_check(X,Module,TestNr,Line,Options) :- |
| 549 | | self_check(X,Module,TestNr,Line), |
| 550 | | (member(run_only_nr(Nr),Options) -> TestNr=Nr ; true). |
| 551 | | |
| 552 | | |
| 553 | | check_test_cases([],[],Nr,Module,_Options) :- |
| 554 | | format('Number of unit tests run in ~w: ~w~n',[Module,Nr]). |
| 555 | | check_test_cases([H|T],[V|VT],Nr,Module,Options) :- |
| 556 | | N1 is Nr+1, |
| 557 | | get_error_count(Module,NrBefore), |
| 558 | | check_test_case(H,N1,V,Options), |
| 559 | | get_error_count(Module,NrAfter), |
| 560 | | (NrBefore=NrAfter -> true |
| 561 | | % ; NrBefore > 0 -> true % we already have a previous unit test failure |
| 562 | | ; H=testcase(_,TestNr,LineNr,_Call), |
| 563 | | format_with_colour(user_error,[red,bold], |
| 564 | | '~n*** UNIT TEST ~w FAILED in module ~w (line ~w)~n',[TestNr,Module,LineNr]), |
| 565 | | format_with_colour(user_error,[red,bold], |
| 566 | | '*** Rerun this test with: probcli -selfcheck_module ~w:~w~n~n',[Module,TestNr]), |
| 567 | | register_failure(Module,TestNr) |
| 568 | | %,portray_testcase(H) |
| 569 | | %%% ,trace %%% |
| 570 | | ), |
| 571 | | check_test_cases(T,VT,N1,Module,Options). |
| 572 | | |
| 573 | | :- use_module(tools_printing,[start_terminal_colour/2, reset_terminal_colour/1]). |
| 574 | | portray_testcase(testcase(Module,TestNr,Line,Call)) :- !, |
| 575 | | start_terminal_colour([blue],user_error), |
| 576 | | format(user_error,'UNIT TEST ~w in module ~w at line ~w:~n :- ',[TestNr,Module,Line]), |
| 577 | | portray_clause(user_error,Call),nl, |
| 578 | | reset_terminal_colour(user_error). |
| 579 | | portray_testcase(X) :- print(unknown_testcase(X)),nl. |
| 580 | | |
| 581 | | |
| 582 | | check_test_case(testcase(Module,Nr,Line,Call), TotNr, Verdict,Options) :- |
| 583 | | (member(silent,Options) -> true ; format('Running unit test ~w in module ~w (line ~w)~n',[Nr,Module,Line])), |
| 584 | | set_error_context(unit_test_context(Module,TotNr,Line,Call)), |
| 585 | | statistics(runtime,[T1,_]), |
| 586 | | (member(verbose,Options) -> portray_clause(Call) ; true), |
| 587 | | safe_call(Call), |
| 588 | | flush_output, |
| 589 | | statistics(runtime,[T2,_]), |
| 590 | | Time is T2-T1, |
| 591 | | (member(verbose,Options) -> format('Runtime for unit test ~w: ~w ms~n',[TotNr,Time]) |
| 592 | | ; Time>20 -> format('*~w ms*~n',[Time]) ; true), |
| 593 | | (Time>2000 -> format_with_colour(user_output,[blue],'Warning: long unit test ~w: ~w ms in module ~w (line ~w)~n ~w~n',[TotNr,Time,Module,Line,Call]) ; true), |
| 594 | | (get_all_errors_and_reset(Errors) -> V=error(Errors) ; V=pass), |
| 595 | | create_junit_result(Call, Time, V, Verdict). |
| 596 | | |
| 597 | | |
| 598 | | perform_self_check(M) :- perform_self_check(M,[]). |
| 599 | | perform_self_check :- perform_self_check(_). |
| 600 | | perform_verbose_self_check :- perform_verbose_self_check(_). |
| 601 | | perform_verbose_self_check(M) :- perform_self_check(M,[verbose]). |
| 602 | | |
| 603 | | :- use_module(eventhandling,[announce_event/1]). |
| 604 | | perform_self_check(Module,Options) :- nl, reset_found_id, |
| 605 | | reset_error_summary, |
| 606 | | announce_event(start_unit_tests), |
| 607 | | flush_output, |
| 608 | | print('% '), |
| 609 | | retractall(starttime(_)), |
| 610 | | statistics(runtime,[Start,_]), assertz(starttime(Start)), |
| 611 | | if(self_check_module(Module,NrTests),true, |
| 612 | | (my_print_error(illegal_module(Module)),inc_error_count, |
| 613 | | fail) |
| 614 | | ), |
| 615 | | set_current_module(Module), |
| 616 | | (member(silent,Options) -> true ; format_with_colour(user_output,[blue],'~n~nPerforming ~w unit tests for module ~w~n',[NrTests,Module])), |
| 617 | | run_module_tests(Module,TestResults,Options), |
| 618 | | print_junit(['Selfcheck',Module], TestResults), |
| 619 | | fail. |
| 620 | | perform_self_check(_,_) :- |
| 621 | | statistics(runtime,[End,_]), |
| 622 | | starttime(Start), Tot is End-Start, |
| 623 | | nl, print('Runtime for Performing Unit Tests: '), print(Tot), print(' ms'), |
| 624 | | nl, |
| 625 | | announce_event(stop_unit_tests), |
| 626 | | clear_error_context, |
| 627 | | print_summary, |
| 628 | | (errors_in_module(_,_) |
| 629 | | -> format_with_colour(user_error,[red,bold],'~n! Unit Tests FAILED !!!~n',[]), |
| 630 | | print_error_summary, |
| 631 | | fail |
| 632 | | ; true), |
| 633 | | format_with_colour(user_output,[green],'~nUnit Tests Successful.~n',[]), |
| 634 | | flush_output. |
| 635 | | |
| 636 | | |
| 637 | | portray_self_checks :- portray_self_checks(_). |
| 638 | | |
| 639 | | /* self_check:portray_self_checks */ |
| 640 | | portray_self_checks(Module) :- |
| 641 | | self_check_module(Module,NrTests), |
| 642 | | format_with_colour(user_output,[blue],'~n~nUnit Tests (~w) for Module ~w~n',[NrTests,Module]), |
| 643 | | self_check(X,Module,Nr,Line), |
| 644 | | format_with_colour(user_output,[blue],' ~w (line ~w): ',[Nr, Line]), |
| 645 | | portray_clause(X), |
| 646 | | fail. |
| 647 | | portray_self_checks(_) :- nl. |
| 648 | | |
| 649 | | % ------------------------ |
| 650 | | |
| 651 | | :- dynamic det_counter/1. |
| 652 | | det_counter(0). |
| 653 | | check_deterministic(Call) :- |
| 654 | | retract(det_counter(X)), X1 is X+1, assertz(det_counter(X1)), |
| 655 | | check_det2(Call,X). |
| 656 | | check_det(Call) :- check_deterministic(Call). |
| 657 | | |
| 658 | | :- volatile calling/1. |
| 659 | | :- dynamic calling/1. |
| 660 | | check_det2(Call,X) :- assertz(calling(X)), |
| 661 | | call(Call), |
| 662 | | (retract(calling(X)) -> true |
| 663 | | ; nl, |
| 664 | | print('### Call has multiple solutions: '),nl, |
| 665 | | print('### '), print(Call),nl, |
| 666 | | nl |
| 667 | | ). |
| 668 | | check_det2(Call,X) :- (retract(calling(X)) -> print(fails(Call)),nl ; fail). |
| 669 | | |
| 670 | | |
| 671 | | % ------------------------ |
| 672 | | |
| 673 | | check_eq(A,B) :- (A=B -> true ; format(user_error,'! Not unifiable:~n ~w~n ~w~n',[A,B]),fail). |
| 674 | | check_eqeq(A,B) :- (A==B -> true ; format(user_error,'! Not identical:~n ~w~n ~w~n',[A,B]),fail). |