plunit.pl

View source with raw comments or as raw
   1/*  Part of SWI-Prolog
   2
   3    Author:        Jan Wielemaker
   4    E-mail:        J.Wielemaker@vu.nl
   5    WWW:           http://www.swi-prolog.org
   6    Copyright (c)  2006-2015, University of Amsterdam
   7                              VU University Amsterdam
   8    All rights reserved.
   9
  10    Redistribution and use in source and binary forms, with or without
  11    modification, are permitted provided that the following conditions
  12    are met:
  13
  14    1. Redistributions of source code must retain the above copyright
  15       notice, this list of conditions and the following disclaimer.
  16
  17    2. Redistributions in binary form must reproduce the above copyright
  18       notice, this list of conditions and the following disclaimer in
  19       the documentation and/or other materials provided with the
  20       distribution.
  21
  22    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  23    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  24    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
  25    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  26    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
  27    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
  28    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
  29    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
  30    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  31    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
  32    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  33    POSSIBILITY OF SUCH DAMAGE.
  34*/
  35
  36:- module(plunit,
  37          [ set_test_options/1,         % +Options
  38            begin_tests/1,              % +Name
  39            begin_tests/2,              % +Name, +Options
  40            end_tests/1,                % +Name
  41            run_tests/0,                % Run all tests
  42            run_tests/1,                % Run named test-set
  43            load_test_files/1,          % +Options
  44            running_tests/0,            % Prints currently running test
  45            test_report/1               % +What
  46          ]).
  47
  48/** <module> Unit Testing
  49
  50Unit testing environment for SWI-Prolog and   SICStus Prolog. For usage,
  51please visit http://www.swi-prolog.org/pldoc/package/plunit.html.
  52
  53@author         Jan Wielemaker
  54@license        GPL+SWI-exception or Artistic 2.0
  55*/
  56
  57:- use_module(library(apply)).
  58:- use_module(library(ordsets), [ord_intersection/3]).
  59:- meta_predicate valid_options(+, 1).
  60
  61
  62                 /*******************************
  63                 *    CONDITIONAL COMPILATION   *
  64                 *******************************/
  65
  66:- discontiguous
  67    user:term_expansion/2.
  68
  69:- dynamic
  70    include_code/1.
  71
  72including :-
  73    include_code(X),
  74    !,
  75    X == true.
  76including.
  77
  78if_expansion((:- if(G)), []) :-
  79    (   including
  80    ->  (   catch(G, E, (print_message(error, E), fail))
  81        ->  asserta(include_code(true))
  82        ;   asserta(include_code(false))
  83        )
  84    ;   asserta(include_code(else_false))
  85    ).
  86if_expansion((:- else), []) :-
  87    (   retract(include_code(X))
  88    ->  (   X == true
  89        ->  X2 = false
  90        ;   X == false
  91        ->  X2 = true
  92        ;   X2 = X
  93        ),
  94        asserta(include_code(X2))
  95    ;   throw_error(context_error(no_if),_)
  96    ).
  97if_expansion((:- endif), []) :-
  98    retract(include_code(_)),
  99    !.
 100
 101if_expansion(_, []) :-
 102    \+ including.
 103
 104user:term_expansion(In, Out) :-
 105    prolog_load_context(module, plunit),
 106    if_expansion(In, Out).
 107
 108swi     :- catch(current_prolog_flag(dialect, swi), _, fail), !.
 109swi     :- catch(current_prolog_flag(dialect, yap), _, fail).
 110sicstus :- catch(current_prolog_flag(system_type, _), _, fail).
 111
 112
 113:- if(swi).
 114throw_error(Error_term,Impldef) :-
 115    throw(error(Error_term,context(Impldef,_))).
 116
 117:- set_prolog_flag(generate_debug_info, false).
 118:- use_module(library(option)).
 119:- use_module(library(pairs)).
 120
 121current_test_flag(Name, Value) :-
 122    current_prolog_flag(Name, Value).
 123
 124set_test_flag(Name, Value) :-
 125    create_prolog_flag(Name, Value, []).
 126
 127% ensure expansion to avoid tracing
 128goal_expansion(forall(C,A),
 129               \+ (C, \+ A)).
 130goal_expansion(current_module(Module,File),
 131               module_property(Module, file(File))).
 132
 133:- if(current_prolog_flag(dialect, yap)).
 134
 135'$set_predicate_attribute'(_, _, _).
 136
 137:- endif.
 138:- endif.
 139
 140:- if(sicstus).
 141throw_error(Error_term,Impldef) :-
 142    throw(error(Error_term,i(Impldef))). % SICStus 3 work around
 143
 144:- use_module(swi).                     % SWI-Compatibility
 145:- use_module(library(terms)).
 146:- op(700, xfx, =@=).
 147
 148'$set_source_module'(_, _).
 149
 150%!  current_test_flag(?Name, ?Value) is nondet.
 151%
 152%   Query  flags  that  control  the    testing   process.  Emulates
 153%   SWI-Prologs flags.
 154
 155:- dynamic test_flag/2. % Name, Val
 156
 157current_test_flag(optimise, Val) :-
 158    current_prolog_flag(compiling, Compiling),
 159    (   Compiling == debugcode ; true % TBD: Proper test
 160    ->  Val = false
 161    ;   Val = true
 162    ).
 163current_test_flag(Name, Val) :-
 164    test_flag(Name, Val).
 165
 166
 167%!  set_test_flag(+Name, +Value) is det.
 168
 169set_test_flag(Name, Val) :-
 170    var(Name),
 171    !,
 172    throw_error(instantiation_error, set_test_flag(Name,Val)).
 173set_test_flag( Name, Val ) :-
 174    retractall(test_flag(Name,_)),
 175    asserta(test_flag(Name, Val)).
 176
 177:- op(1150, fx, thread_local).
 178
 179user:term_expansion((:- thread_local(PI)), (:- dynamic(PI))) :-
 180    prolog_load_context(module, plunit).
 181
 182:- endif.
 183
 184                 /*******************************
 185                 *            IMPORTS           *
 186                 *******************************/
 187
 188:- use_module(library(lists)).
 189
 190:- initialization
 191   (   current_test_flag(test_options, _)
 192   ->  true
 193   ;   set_test_flag(test_options,
 194                 [ run(make),       % run tests on make/0
 195                   sto(false)
 196                 ])
 197   ).
 198
 199%!  set_test_options(+Options)
 200%
 201%   Specifies how to deal with test suites.  Defined options are:
 202%
 203%           * load(+Load)
 204%           Whether or not the tests must be loaded.  Values are
 205%           =never=, =always=, =normal= (only if not optimised)
 206%
 207%           * run(+When)
 208%           When the tests are run.  Values are =manual=, =make=
 209%           or make(all).
 210%
 211%           * silent(+Bool)
 212%           If =true= (default =false=), report successful tests
 213%           using message level =silent=, only printing errors and
 214%           warnings.
 215%
 216%           * sto(+Bool)
 217%           How to test whether code is subject to occurs check
 218%           (STO).  If =false= (default), STO is not considered.
 219%           If =true= and supported by the hosting Prolog, code
 220%           is run in all supported unification mode and reported
 221%           if the results are inconsistent.
 222%
 223%           * cleanup(+Bool)
 224%           If =true= (default =false), cleanup report at the end
 225%           of run_tests/1.  Used to improve cooperation with
 226%           memory debuggers such as dmalloc.
 227
 228set_test_options(Options) :-
 229    valid_options(Options, global_test_option),
 230    set_test_flag(test_options, Options).
 231
 232global_test_option(load(Load)) :-
 233    must_be(oneof([never,always,normal]), Load).
 234global_test_option(run(When)) :-
 235    must_be(oneof([manual,make,make(all)]), When).
 236global_test_option(silent(Bool)) :-
 237    must_be(boolean, Bool).
 238global_test_option(sto(Bool)) :-
 239    must_be(boolean, Bool).
 240global_test_option(cleanup(Bool)) :-
 241    must_be(boolean, Bool).
 242
 243
 244%!  loading_tests
 245%
 246%   True if tests must be loaded.
 247
 248loading_tests :-
 249    current_test_flag(test_options, Options),
 250    option(load(Load), Options, normal),
 251    (   Load == always
 252    ->  true
 253    ;   Load == normal,
 254        \+ current_test_flag(optimise, true)
 255    ).
 256
 257                 /*******************************
 258                 *            MODULE            *
 259                 *******************************/
 260
 261:- dynamic
 262    loading_unit/4,                 % Unit, Module, File, OldSource
 263    current_unit/4,                 % Unit, Module, Context, Options
 264    test_file_for/2.                % ?TestFile, ?PrologFile
 265
 266%!  begin_tests(+UnitName:atom) is det.
 267%!  begin_tests(+UnitName:atom, Options) is det.
 268%
 269%   Start a test-unit. UnitName is the  name   of  the test set. the
 270%   unit is ended by :- end_tests(UnitName).
 271
 272begin_tests(Unit) :-
 273    begin_tests(Unit, []).
 274
 275begin_tests(Unit, Options) :-
 276    valid_options(Options, test_set_option),
 277    make_unit_module(Unit, Name),
 278    source_location(File, Line),
 279    begin_tests(Unit, Name, File:Line, Options).
 280
 281:- if(swi).
 282begin_tests(Unit, Name, File:Line, Options) :-
 283    loading_tests,
 284    !,
 285    '$set_source_module'(Context, Context),
 286    (   current_unit(Unit, Name, Context, Options)
 287    ->  true
 288    ;   retractall(current_unit(Unit, Name, _, _)),
 289        assert(current_unit(Unit, Name, Context, Options))
 290    ),
 291    '$set_source_module'(Old, Name),
 292    '$declare_module'(Name, test, Context, File, Line, false),
 293    discontiguous(Name:'unit test'/4),
 294    '$set_predicate_attribute'(Name:'unit test'/4, trace, false),
 295    discontiguous(Name:'unit body'/2),
 296    asserta(loading_unit(Unit, Name, File, Old)).
 297begin_tests(Unit, Name, File:_Line, _Options) :-
 298    '$set_source_module'(Old, Old),
 299    asserta(loading_unit(Unit, Name, File, Old)).
 300
 301:- else.
 302
 303% we cannot use discontiguous as a goal in SICStus Prolog.
 304
 305user:term_expansion((:- begin_tests(Set)),
 306                    [ (:- begin_tests(Set)),
 307                      (:- discontiguous(test/2)),
 308                      (:- discontiguous('unit body'/2)),
 309                      (:- discontiguous('unit test'/4))
 310                    ]).
 311
 312begin_tests(Unit, Name, File:_Line, Options) :-
 313    loading_tests,
 314    !,
 315    (   current_unit(Unit, Name, _, Options)
 316    ->  true
 317    ;   retractall(current_unit(Unit, Name, _, _)),
 318        assert(current_unit(Unit, Name, -, Options))
 319    ),
 320    asserta(loading_unit(Unit, Name, File, -)).
 321begin_tests(Unit, Name, File:_Line, _Options) :-
 322    asserta(loading_unit(Unit, Name, File, -)).
 323
 324:- endif.
 325
 326%!  end_tests(+Name) is det.
 327%
 328%   Close a unit-test module.
 329%
 330%   @tbd    Run tests/clean module?
 331%   @tbd    End of file?
 332
 333end_tests(Unit) :-
 334    loading_unit(StartUnit, _, _, _),
 335    !,
 336    (   Unit == StartUnit
 337    ->  once(retract(loading_unit(StartUnit, _, _, Old))),
 338        '$set_source_module'(_, Old)
 339    ;   throw_error(context_error(plunit_close(Unit, StartUnit)), _)
 340    ).
 341end_tests(Unit) :-
 342    throw_error(context_error(plunit_close(Unit, -)), _).
 343
 344%!  make_unit_module(+Name, -ModuleName) is det.
 345%!  unit_module(+Name, -ModuleName) is det.
 346
 347:- if(swi).
 348
 349unit_module(Unit, Module) :-
 350    atom_concat('plunit_', Unit, Module).
 351
 352make_unit_module(Unit, Module) :-
 353    unit_module(Unit, Module),
 354    (   current_module(Module),
 355        \+ current_unit(_, Module, _, _),
 356        predicate_property(Module:H, _P),
 357        \+ predicate_property(Module:H, imported_from(_M))
 358    ->  throw_error(permission_error(create, plunit, Unit),
 359                    'Existing module')
 360    ;  true
 361    ).
 362
 363:- else.
 364
 365:- dynamic
 366    unit_module_store/2.
 367
 368unit_module(Unit, Module) :-
 369    unit_module_store(Unit, Module),
 370    !.
 371
 372make_unit_module(Unit, Module) :-
 373    prolog_load_context(module, Module),
 374    assert(unit_module_store(Unit, Module)).
 375
 376:- endif.
 377
 378                 /*******************************
 379                 *           EXPANSION          *
 380                 *******************************/
 381
 382%!  expand_test(+Name, +Options, +Body, -Clause) is det.
 383%
 384%   Expand test(Name, Options) :-  Body  into   a  clause  for
 385%   'unit test'/4 and 'unit body'/2.
 386
 387expand_test(Name, Options0, Body,
 388            [ 'unit test'(Name, Line, Options, Module:'unit body'(Id, Vars)),
 389              ('unit body'(Id, Vars) :- !, Body)
 390            ]) :-
 391    source_location(_File, Line),
 392    prolog_load_context(module, Module),
 393    atomic_list_concat([Name, '@line ', Line], Id),
 394    term_variables(Options0, OptionVars0), sort(OptionVars0, OptionVars),
 395    term_variables(Body, BodyVars0), sort(BodyVars0, BodyVars),
 396    ord_intersection(OptionVars, BodyVars, VarList),
 397    Vars =.. [vars|VarList],
 398    (   is_list(Options0)           % allow for single option without list
 399    ->  Options1 = Options0
 400    ;   Options1 = [Options0]
 401    ),
 402    maplist(expand_option, Options1, Options2),
 403    valid_options(Options2, test_option),
 404    valid_test_mode(Options2, Options).
 405
 406expand_option(Var, _) :-
 407    var(Var),
 408    !,
 409    throw_error(instantiation_error,_).
 410expand_option(A == B, true(A==B)) :- !.
 411expand_option(A = B, true(A=B)) :- !.
 412expand_option(A =@= B, true(A=@=B)) :- !.
 413expand_option(A =:= B, true(A=:=B)) :- !.
 414expand_option(error(X), throws(error(X, _))) :- !.
 415expand_option(exception(X), throws(X)) :- !. % SICStus 4 compatibility
 416expand_option(error(F,C), throws(error(F,C))) :- !. % SICStus 4 compatibility
 417expand_option(true, true(true)) :- !.
 418expand_option(O, O).
 419
 420valid_test_mode(Options0, Options) :-
 421    include(test_mode, Options0, Tests),
 422    (   Tests == []
 423    ->  Options = [true(true)|Options0]
 424    ;   Tests = [_]
 425    ->  Options = Options0
 426    ;   throw_error(plunit(incompatible_options, Tests), _)
 427    ).
 428
 429test_mode(true(_)).
 430test_mode(all(_)).
 431test_mode(set(_)).
 432test_mode(fail).
 433test_mode(throws(_)).
 434
 435
 436%!  expand(+Term, -Clauses) is semidet.
 437
 438expand(end_of_file, _) :-
 439    loading_unit(Unit, _, _, _),
 440    !,
 441    end_tests(Unit),                % warn?
 442    fail.
 443expand((:-end_tests(_)), _) :-
 444    !,
 445    fail.
 446expand(_Term, []) :-
 447    \+ loading_tests.
 448expand((test(Name) :- Body), Clauses) :-
 449    !,
 450    expand_test(Name, [], Body, Clauses).
 451expand((test(Name, Options) :- Body), Clauses) :-
 452    !,
 453    expand_test(Name, Options, Body, Clauses).
 454expand(test(Name), _) :-
 455    !,
 456    throw_error(existence_error(body, test(Name)), _).
 457expand(test(Name, _Options), _) :-
 458    !,
 459    throw_error(existence_error(body, test(Name)), _).
 460
 461:- if(swi).
 462:- multifile
 463    system:term_expansion/2.
 464:- endif.
 465
 466system:term_expansion(Term, Expanded) :-
 467    (   loading_unit(_, _, File, _)
 468    ->  source_location(File, _),
 469        expand(Term, Expanded)
 470    ).
 471
 472
 473                 /*******************************
 474                 *             OPTIONS          *
 475                 *******************************/
 476
 477:- if(swi).
 478:- use_module(library(error)).
 479:- else.
 480must_be(list, X) :-
 481    !,
 482    (   is_list(X)
 483    ->  true
 484    ;   is_not(list, X)
 485    ).
 486must_be(Type, X) :-
 487    (   call(Type, X)
 488    ->  true
 489    ;   is_not(Type, X)
 490    ).
 491
 492is_not(Type, X) :-
 493    (   ground(X)
 494    ->  throw_error(type_error(Type, X), _)
 495    ;   throw_error(instantiation_error, _)
 496    ).
 497:- endif.
 498
 499%!  valid_options(+Options, :Pred) is det.
 500%
 501%   Verify Options to be a list of valid options according to
 502%   Pred.
 503%
 504%   @throws =type_error= or =instantiation_error=.
 505
 506valid_options(Options, Pred) :-
 507    must_be(list, Options),
 508    verify_options(Options, Pred).
 509
 510verify_options([], _).
 511verify_options([H|T], Pred) :-
 512    (   call(Pred, H)
 513    ->  verify_options(T, Pred)
 514    ;   throw_error(domain_error(Pred, H), _)
 515    ).
 516
 517
 518%!  test_option(+Option) is semidet.
 519%
 520%   True if Option is a valid option for test(Name, Options).
 521
 522test_option(Option) :-
 523    test_set_option(Option),
 524    !.
 525test_option(true(_)).
 526test_option(fail).
 527test_option(throws(_)).
 528test_option(all(_)).
 529test_option(set(_)).
 530test_option(nondet).
 531test_option(fixme(_)).
 532test_option(forall(X)) :-
 533    must_be(callable, X).
 534
 535%!  test_option(+Option) is semidet.
 536%
 537%   True if Option is a valid option for :- begin_tests(Name,
 538%   Options).
 539
 540test_set_option(blocked(X)) :-
 541    must_be(ground, X).
 542test_set_option(condition(X)) :-
 543    must_be(callable, X).
 544test_set_option(setup(X)) :-
 545    must_be(callable, X).
 546test_set_option(cleanup(X)) :-
 547    must_be(callable, X).
 548test_set_option(sto(V)) :-
 549    nonvar(V), member(V, [finite_trees, rational_trees]).
 550
 551
 552                 /*******************************
 553                 *        RUNNING TOPLEVEL      *
 554                 *******************************/
 555
 556:- thread_local
 557    passed/5,                       % Unit, Test, Line, Det, Time
 558    failed/4,                       % Unit, Test, Line, Reason
 559    failed_assertion/7,             % Unit, Test, Line, ALoc, STO, Reason, Goal
 560    blocked/4,                      % Unit, Test, Line, Reason
 561    sto/4,                          % Unit, Test, Line, Results
 562    fixme/5.                        % Unit, Test, Line, Reason, Status
 563
 564:- dynamic
 565    running/5.                      % Unit, Test, Line, STO, Thread
 566
 567%!  run_tests is semidet.
 568%!  run_tests(+TestSet) is semidet.
 569%
 570%   Run  tests  and  report  about    the   results.  The  predicate
 571%   run_tests/0 runs all known  tests  that   are  not  blocked. The
 572%   predicate run_tests/1 takes a  specification   of  tests to run.
 573%   This  is  either  a  single   specification    or   a   list  of
 574%   specifications. Each single specification is  either the name of
 575%   a test-unit or a term <test-unit>:<test>, denoting a single test
 576%   within a unit.
 577
 578run_tests :-
 579    cleanup,
 580    setup_call_cleanup(
 581        setup_trap_assertions(Ref),
 582        run_current_units,
 583        report_and_cleanup(Ref)).
 584
 585run_current_units :-
 586    forall(current_test_set(Set),
 587           run_unit(Set)),
 588    check_for_test_errors.
 589
 590report_and_cleanup(Ref) :-
 591    cleanup_trap_assertions(Ref),
 592    report,
 593    cleanup_after_test.
 594
 595run_tests(Set) :-
 596    cleanup,
 597    setup_call_cleanup(
 598        setup_trap_assertions(Ref),
 599        run_unit_and_check_errors(Set),
 600        report_and_cleanup(Ref)).
 601
 602run_unit_and_check_errors(Set) :-
 603    run_unit(Set),
 604    check_for_test_errors.
 605
 606run_unit([]) :- !.
 607run_unit([H|T]) :-
 608    !,
 609    run_unit(H),
 610    run_unit(T).
 611run_unit(Spec) :-
 612    unit_from_spec(Spec, Unit, Tests, Module, UnitOptions),
 613    (   option(blocked(Reason), UnitOptions)
 614    ->  info(plunit(blocked(unit(Unit, Reason))))
 615    ;   setup(Module, unit(Unit), UnitOptions)
 616    ->  info(plunit(begin(Spec))),
 617        forall((Module:'unit test'(Name, Line, Options, Body),
 618                matching_test(Name, Tests)),
 619               run_test(Unit, Name, Line, Options, Body)),
 620        info(plunit(end(Spec))),
 621        (   message_level(silent)
 622        ->  true
 623        ;   format(user_error, '~N', [])
 624        ),
 625        cleanup(Module, UnitOptions)
 626    ;   true
 627    ).
 628
 629unit_from_spec(Unit, Unit, _, Module, Options) :-
 630    atom(Unit),
 631    !,
 632    (   current_unit(Unit, Module, _Supers, Options)
 633    ->  true
 634    ;   throw_error(existence_error(unit_test, Unit), _)
 635    ).
 636unit_from_spec(Unit:Tests, Unit, Tests, Module, Options) :-
 637    atom(Unit),
 638    !,
 639    (   current_unit(Unit, Module, _Supers, Options)
 640    ->  true
 641    ;   throw_error(existence_error(unit_test, Unit), _)
 642    ).
 643
 644
 645matching_test(X, X) :- !.
 646matching_test(Name, Set) :-
 647    is_list(Set),
 648    memberchk(Name, Set).
 649
 650cleanup :-
 651    thread_self(Me),
 652    retractall(passed(_, _, _, _, _)),
 653    retractall(failed(_, _, _, _)),
 654    retractall(failed_assertion(_, _, _, _, _, _, _)),
 655    retractall(blocked(_, _, _, _)),
 656    retractall(sto(_, _, _, _)),
 657    retractall(fixme(_, _, _, _, _)),
 658    retractall(running(_,_,_,_,Me)).
 659
 660cleanup_after_test :-
 661    current_test_flag(test_options, Options),
 662    option(cleanup(Cleanup), Options, false),
 663    (   Cleanup == true
 664    ->  cleanup
 665    ;   true
 666    ).
 667
 668
 669%!  run_tests_in_files(+Files:list) is det.
 670%
 671%   Run all test-units that appear in the given Files.
 672
 673run_tests_in_files(Files) :-
 674    findall(Unit, unit_in_files(Files, Unit), Units),
 675    (   Units == []
 676    ->  true
 677    ;   run_tests(Units)
 678    ).
 679
 680unit_in_files(Files, Unit) :-
 681    is_list(Files),
 682    !,
 683    member(F, Files),
 684    absolute_file_name(F, Source,
 685                       [ file_type(prolog),
 686                         access(read),
 687                         file_errors(fail)
 688                       ]),
 689    unit_file(Unit, Source).
 690
 691
 692                 /*******************************
 693                 *         HOOKING MAKE/0       *
 694                 *******************************/
 695
 696%!  make_run_tests(+Files)
 697%
 698%   Called indirectly from make/0 after Files have been reloaded.
 699
 700make_run_tests(Files) :-
 701    current_test_flag(test_options, Options),
 702    option(run(When), Options, manual),
 703    (   When == make
 704    ->  run_tests_in_files(Files)
 705    ;   When == make(all)
 706    ->  run_tests
 707    ;   true
 708    ).
 709
 710:- if(swi).
 711
 712unification_capability(sto_error_incomplete).
 713% can detect some (almost all) STO runs
 714unification_capability(rational_trees).
 715unification_capability(finite_trees).
 716
 717set_unification_capability(Cap) :-
 718    cap_to_flag(Cap, Flag),
 719    set_prolog_flag(occurs_check, Flag).
 720
 721current_unification_capability(Cap) :-
 722    current_prolog_flag(occurs_check, Flag),
 723    cap_to_flag(Cap, Flag),
 724    !.
 725
 726cap_to_flag(sto_error_incomplete, error).
 727cap_to_flag(rational_trees, false).
 728cap_to_flag(finite_trees, true).
 729
 730:- else.
 731:- if(sicstus).
 732
 733unification_capability(rational_trees).
 734set_unification_capability(rational_trees).
 735current_unification_capability(rational_trees).
 736
 737:- else.
 738
 739unification_capability(_) :-
 740    fail.
 741
 742:- endif.
 743:- endif.
 744
 745                 /*******************************
 746                 *      ASSERTION HANDLING      *
 747                 *******************************/
 748
 749:- if(swi).
 750
 751:- dynamic prolog:assertion_failed/2.
 752
 753setup_trap_assertions(Ref) :-
 754    asserta((prolog:assertion_failed(Reason, Goal) :-
 755                    test_assertion_failed(Reason, Goal)),
 756            Ref).
 757
 758cleanup_trap_assertions(Ref) :-
 759    erase(Ref).
 760
 761test_assertion_failed(Reason, Goal) :-
 762    thread_self(Me),
 763    running(Unit, Test, Line, STO, Me),
 764    (   catch(get_prolog_backtrace(10, Stack), _, fail),
 765        assertion_location(Stack, AssertLoc)
 766    ->  true
 767    ;   AssertLoc = unknown
 768    ),
 769    current_test_flag(test_options, Options),
 770    report_failed_assertion(Unit, Test, Line, AssertLoc,
 771                            STO, Reason, Goal, Options),
 772    assert_cyclic(failed_assertion(Unit, Test, Line, AssertLoc,
 773                                   STO, Reason, Goal)).
 774
 775assertion_location(Stack, File:Line) :-
 776    append(_, [AssertFrame,CallerFrame|_], Stack),
 777    prolog_stack_frame_property(AssertFrame,
 778                                predicate(prolog_debug:assertion/1)),
 779    !,
 780    prolog_stack_frame_property(CallerFrame, location(File:Line)).
 781
 782report_failed_assertion(Unit, Test, Line, AssertLoc,
 783                        STO, Reason, Goal, _Options) :-
 784    print_message(
 785        error,
 786        plunit(failed_assertion(Unit, Test, Line, AssertLoc,
 787                                STO, Reason, Goal))).
 788
 789:- else.
 790
 791setup_trap_assertions(_).
 792cleanup_trap_assertions(_).
 793
 794:- endif.
 795
 796
 797
 798
 799
 800                 /*******************************
 801                 *         RUNNING A TEST       *
 802                 *******************************/
 803
 804%!  run_test(+Unit, +Name, +Line, +Options, +Body) is det.
 805%
 806%   Run a single test.
 807
 808run_test(Unit, Name, Line, Options, Body) :-
 809    option(forall(Generator), Options),
 810    !,
 811    unit_module(Unit, Module),
 812    term_variables(Generator, Vars),
 813    forall(Module:Generator,
 814           run_test_once(Unit, @(Name,Vars), Line, Options, Body)).
 815run_test(Unit, Name, Line, Options, Body) :-
 816    run_test_once(Unit, Name, Line, Options, Body).
 817
 818run_test_once(Unit, Name, Line, Options, Body) :-
 819    current_test_flag(test_options, GlobalOptions),
 820    option(sto(false), GlobalOptions, false),
 821    !,
 822    current_unification_capability(Type),
 823    begin_test(Unit, Name, Line, Type),
 824    run_test_6(Unit, Name, Line, Options, Body, Result),
 825    end_test(Unit, Name, Line, Type),
 826    report_result(Result, Options).
 827run_test_once(Unit, Name, Line, Options, Body) :-
 828    current_unit(Unit, _Module, _Supers, UnitOptions),
 829    option(sto(Type), UnitOptions),
 830    \+ option(sto(_), Options),
 831    !,
 832    current_unification_capability(Cap0),
 833    call_cleanup(run_test_cap(Unit, Name, Line, [sto(Type)|Options], Body),
 834                 set_unification_capability(Cap0)).
 835run_test_once(Unit, Name, Line, Options, Body) :-
 836    current_unification_capability(Cap0),
 837    call_cleanup(run_test_cap(Unit, Name, Line, Options, Body),
 838                 set_unification_capability(Cap0)).
 839
 840run_test_cap(Unit, Name, Line, Options, Body) :-
 841    (   option(sto(Type), Options)
 842    ->  unification_capability(Type),
 843        set_unification_capability(Type),
 844        begin_test(Unit, Name, Line, Type),
 845        run_test_6(Unit, Name, Line, Options, Body, Result),
 846        end_test(Unit, Name, Line, Type),
 847        report_result(Result, Options)
 848    ;   findall(Key-(Type+Result),
 849                test_caps(Type, Unit, Name, Line, Options, Body, Result, Key),
 850                Pairs),
 851        group_pairs_by_key(Pairs, Keyed),
 852        (   Keyed == []
 853        ->  true
 854        ;   Keyed = [_-Results]
 855        ->  Results = [_Type+Result|_],
 856            report_result(Result, Options)          % consistent results
 857        ;   pairs_values(Pairs, ResultByType),
 858            report_result(sto(Unit, Name, Line, ResultByType), Options)
 859        )
 860    ).
 861
 862%!  test_caps(-Type, +Unit, +Name, +Line, +Options, +Body, -Result, -Key) is nondet.
 863
 864test_caps(Type, Unit, Name, Line, Options, Body, Result, Key) :-
 865    unification_capability(Type),
 866    set_unification_capability(Type),
 867    begin_test(Unit, Name, Line, Type),
 868    run_test_6(Unit, Name, Line, Options, Body, Result),
 869    end_test(Unit, Name, Line, Type),
 870    result_to_key(Result, Key),
 871    Key \== setup_failed.
 872
 873result_to_key(blocked(_, _, _, _), blocked).
 874result_to_key(failure(_, _, _, How0), failure(How1)) :-
 875    ( How0 = succeeded(_T) -> How1 = succeeded ; How0 = How1 ).
 876result_to_key(success(_, _, _, Determinism, _), success(Determinism)).
 877result_to_key(setup_failed(_,_,_), setup_failed).
 878
 879report_result(blocked(Unit, Name, Line, Reason), _) :-
 880    !,
 881    assert(blocked(Unit, Name, Line, Reason)).
 882report_result(failure(Unit, Name, Line, How), Options) :-
 883    !,
 884    failure(Unit, Name, Line, How, Options).
 885report_result(success(Unit, Name, Line, Determinism, Time), Options) :-
 886    !,
 887    success(Unit, Name, Line, Determinism, Time, Options).
 888report_result(setup_failed(_Unit, _Name, _Line), _Options).
 889report_result(sto(Unit, Name, Line, ResultByType), Options) :-
 890    assert(sto(Unit, Name, Line, ResultByType)),
 891    print_message(error, plunit(sto(Unit, Name, Line))),
 892    report_sto_results(ResultByType, Options).
 893
 894report_sto_results([], _).
 895report_sto_results([Type+Result|T], Options) :-
 896    print_message(error, plunit(sto(Type, Result))),
 897    report_sto_results(T, Options).
 898
 899
 900%!  run_test_6(+Unit, +Name, +Line, +Options, :Body, -Result) is det.
 901%
 902%   Result is one of:
 903%
 904%           * blocked(Unit, Name, Line, Reason)
 905%           * failure(Unit, Name, Line, How)
 906%           * success(Unit, Name, Line, Determinism, Time)
 907%           * setup_failed(Unit, Name, Line)
 908
 909run_test_6(Unit, Name, Line, Options, _Body,
 910           blocked(Unit, Name, Line, Reason)) :-
 911    option(blocked(Reason), Options),
 912    !.
 913run_test_6(Unit, Name, Line, Options, Body, Result) :-
 914    option(all(Answer), Options),                  % all(Bindings)
 915    !,
 916    nondet_test(all(Answer), Unit, Name, Line, Options, Body, Result).
 917run_test_6(Unit, Name, Line, Options, Body, Result) :-
 918    option(set(Answer), Options),                  % set(Bindings)
 919    !,
 920    nondet_test(set(Answer), Unit, Name, Line, Options, Body, Result).
 921run_test_6(Unit, Name, Line, Options, Body, Result) :-
 922    option(fail, Options),                         % fail
 923    !,
 924    unit_module(Unit, Module),
 925    (   setup(Module, test(Unit,Name,Line), Options)
 926    ->  statistics(runtime, [T0,_]),
 927        (   catch(Module:Body, E, true)
 928        ->  (   var(E)
 929            ->  statistics(runtime, [T1,_]),
 930                Time is (T1 - T0)/1000.0,
 931                Result = failure(Unit, Name, Line, succeeded(Time)),
 932                cleanup(Module, Options)
 933            ;   Result = failure(Unit, Name, Line, E),
 934                cleanup(Module, Options)
 935            )
 936        ;   statistics(runtime, [T1,_]),
 937            Time is (T1 - T0)/1000.0,
 938            Result = success(Unit, Name, Line, true, Time),
 939            cleanup(Module, Options)
 940        )
 941    ;   Result = setup_failed(Unit, Name, Line)
 942    ).
 943run_test_6(Unit, Name, Line, Options, Body, Result) :-
 944    option(true(Cmp), Options),
 945    !,
 946    unit_module(Unit, Module),
 947    (   setup(Module, test(Unit,Name,Line), Options) % true(Binding)
 948    ->  statistics(runtime, [T0,_]),
 949        (   catch(call_det(Module:Body, Det), E, true)
 950        ->  (   var(E)
 951            ->  statistics(runtime, [T1,_]),
 952                Time is (T1 - T0)/1000.0,
 953                (   catch(Module:Cmp, E, true)
 954                ->  (   var(E)
 955                    ->  Result = success(Unit, Name, Line, Det, Time)
 956                    ;   Result = failure(Unit, Name, Line, cmp_error(Cmp, E))
 957                    )
 958                ;   Result = failure(Unit, Name, Line, wrong_answer(Cmp))
 959                ),
 960                cleanup(Module, Options)
 961            ;   Result = failure(Unit, Name, Line, E),
 962                cleanup(Module, Options)
 963            )
 964        ;   Result = failure(Unit, Name, Line, failed),
 965            cleanup(Module, Options)
 966        )
 967    ;   Result = setup_failed(Unit, Name, Line)
 968    ).
 969run_test_6(Unit, Name, Line, Options, Body, Result) :-
 970    option(throws(Expect), Options),
 971    !,
 972    unit_module(Unit, Module),
 973    (   setup(Module, test(Unit,Name,Line), Options)
 974    ->  statistics(runtime, [T0,_]),
 975        (   catch(Module:Body, E, true)
 976        ->  (   var(E)
 977            ->  Result = failure(Unit, Name, Line, no_exception),
 978                cleanup(Module, Options)
 979            ;   statistics(runtime, [T1,_]),
 980                Time is (T1 - T0)/1000.0,
 981                (   match_error(Expect, E)
 982                ->  Result = success(Unit, Name, Line, true, Time)
 983                ;   Result = failure(Unit, Name, Line, wrong_error(Expect, E))
 984                ),
 985                cleanup(Module, Options)
 986            )
 987        ;   Result = failure(Unit, Name, Line, failed),
 988            cleanup(Module, Options)
 989        )
 990    ;   Result = setup_failed(Unit, Name, Line)
 991    ).
 992
 993
 994%!  non_det_test(+Expected, +Unit, +Name, +Line, +Options, +Body, -Result)
 995%
 996%   Run tests on non-deterministic predicates.
 997
 998nondet_test(Expected, Unit, Name, Line, Options, Body, Result) :-
 999    unit_module(Unit, Module),
1000    result_vars(Expected, Vars),
1001    statistics(runtime, [T0,_]),
1002    (   setup(Module, test(Unit,Name,Line), Options)
1003    ->  (   catch(findall(Vars, Module:Body, Bindings), E, true)
1004        ->  (   var(E)
1005            ->  statistics(runtime, [T1,_]),
1006                Time is (T1 - T0)/1000.0,
1007                (   nondet_compare(Expected, Bindings, Unit, Name, Line)
1008                ->  Result = success(Unit, Name, Line, true, Time)
1009                ;   Result = failure(Unit, Name, Line, wrong_answer(Expected, Bindings))
1010                ),
1011                cleanup(Module, Options)
1012            ;   Result = failure(Unit, Name, Line, E),
1013                cleanup(Module, Options)
1014            )
1015        )
1016    ;   Result = setup_failed(Unit, Name, Line)
1017    ).
1018
1019
1020%!  result_vars(+Expected, -Vars) is det.
1021%
1022%   Create a term v(V1, ...) containing all variables at the left
1023%   side of the comparison operator on Expected.
1024
1025result_vars(Expected, Vars) :-
1026    arg(1, Expected, CmpOp),
1027    arg(1, CmpOp, Vars).
1028
1029%!  nondet_compare(+Expected, +Bindings, +Unit, +Name, +Line) is semidet.
1030%
1031%   Compare list/set results for non-deterministic predicates.
1032%
1033%   @tbd    Properly report errors
1034%   @bug    Sort should deal with equivalence on the comparison
1035%           operator.
1036
1037nondet_compare(all(Cmp), Bindings, _Unit, _Name, _Line) :-
1038    cmp(Cmp, _Vars, Op, Values),
1039    cmp_list(Values, Bindings, Op).
1040nondet_compare(set(Cmp), Bindings0, _Unit, _Name, _Line) :-
1041    cmp(Cmp, _Vars, Op, Values0),
1042    sort(Bindings0, Bindings),
1043    sort(Values0, Values),
1044    cmp_list(Values, Bindings, Op).
1045
1046cmp_list([], [], _Op).
1047cmp_list([E0|ET], [V0|VT], Op) :-
1048    call(Op, E0, V0),
1049    cmp_list(ET, VT, Op).
1050
1051%!  cmp(+CmpTerm, -Left, -Op, -Right) is det.
1052
1053cmp(Var  == Value, Var,  ==, Value).
1054cmp(Var =:= Value, Var, =:=, Value).
1055cmp(Var  =  Value, Var,  =,  Value).
1056:- if(swi).
1057cmp(Var =@= Value, Var, =@=, Value).
1058:- else.
1059:- if(sicstus).
1060cmp(Var =@= Value, Var, variant, Value). % variant/2 is the same =@=
1061:- endif.
1062:- endif.
1063
1064
1065%!  call_det(:Goal, -Det) is nondet.
1066%
1067%   True if Goal succeeded.  Det is unified to =true= if Goal left
1068%   no choicepoints and =false= otherwise.
1069
1070:- if((swi|sicstus)).
1071call_det(Goal, Det) :-
1072    call_cleanup(Goal,Det0=true),
1073    ( var(Det0) -> Det = false ; Det = true ).
1074:- else.
1075call_det(Goal, true) :-
1076    call(Goal).
1077:- endif.
1078
1079%!  match_error(+Expected, +Received) is semidet.
1080%
1081%   True if the Received errors matches the expected error. Matching
1082%   is based on subsumes_term/2.
1083
1084match_error(Expect, Rec) :-
1085    subsumes_term(Expect, Rec).
1086
1087%!  setup(+Module, +Context, +Options) is semidet.
1088%
1089%   Call the setup handler and  fail  if   it  cannot  run  for some
1090%   reason. The condition handler is  similar,   but  failing is not
1091%   considered an error.  Context is one of
1092%
1093%       * unit(Unit)
1094%       If it is the setup handler for a unit
1095%       * test(Unit,Name,Line)
1096%       If it is the setup handler for a test
1097
1098setup(Module, Context, Options) :-
1099    option(condition(Condition), Options),
1100    option(setup(Setup), Options),
1101    !,
1102    setup(Module, Context, [condition(Condition)]),
1103    setup(Module, Context, [setup(Setup)]).
1104setup(Module, Context, Options) :-
1105    option(setup(Setup), Options),
1106    !,
1107    (   catch(call_ex(Module, Setup), E, true)
1108    ->  (   var(E)
1109        ->  true
1110        ;   print_message(error, plunit(error(setup, Context, E))),
1111            fail
1112        )
1113    ;   print_message(error, error(goal_failed(Setup), _)),
1114        fail
1115    ).
1116setup(Module, Context, Options) :-
1117    option(condition(Setup), Options),
1118    !,
1119    (   catch(call_ex(Module, Setup), E, true)
1120    ->  (   var(E)
1121        ->  true
1122        ;   print_message(error, plunit(error(condition, Context, E))),
1123            fail
1124        )
1125    ;   fail
1126    ).
1127setup(_,_,_).
1128
1129%!  call_ex(+Module, +Goal)
1130%
1131%   Call Goal in Module after applying goal expansion.
1132
1133call_ex(Module, Goal) :-
1134    Module:(expand_goal(Goal, GoalEx),
1135                GoalEx).
1136
1137%!  cleanup(+Module, +Options) is det.
1138%
1139%   Call the cleanup handler and succeed.   Failure  or error of the
1140%   cleanup handler is reported, but tests continue normally.
1141
1142cleanup(Module, Options) :-
1143    option(cleanup(Cleanup), Options, true),
1144    (   catch(call_ex(Module, Cleanup), E, true)
1145    ->  (   var(E)
1146        ->  true
1147        ;   print_message(warning, E)
1148        )
1149    ;   print_message(warning, goal_failed(Cleanup, '(cleanup handler)'))
1150    ).
1151
1152success(Unit, Name, Line, Det, _Time, Options) :-
1153    memberchk(fixme(Reason), Options),
1154    !,
1155    (   (   Det == true
1156        ;   memberchk(nondet, Options)
1157        )
1158    ->  put_char(user_error, +),
1159        Ok = passed
1160    ;   put_char(user_error, !),
1161        Ok = nondet
1162    ),
1163    flush_output(user_error),
1164    assert(fixme(Unit, Name, Line, Reason, Ok)).
1165success(Unit, Name, Line, _, _, Options) :-
1166    failed_assertion(Unit, Name, Line, _,_,_,_),
1167    !,
1168    failure(Unit, Name, Line, assertion, Options).
1169success(Unit, Name, Line, Det, Time, Options) :-
1170    assert(passed(Unit, Name, Line, Det, Time)),
1171    (   (   Det == true
1172        ;   memberchk(nondet, Options)
1173        )
1174    ->  put_char(user_error, .)
1175    ;   unit_file(Unit, File),
1176        print_message(warning, plunit(nondet(File, Line, Name)))
1177    ),
1178    flush_output(user_error).
1179
1180failure(Unit, Name, Line, _, Options) :-
1181    memberchk(fixme(Reason), Options),
1182    !,
1183    put_char(user_error, -),
1184    flush_output(user_error),
1185    assert(fixme(Unit, Name, Line, Reason, failed)).
1186failure(Unit, Name, Line, E, Options) :-
1187    report_failure(Unit, Name, Line, E, Options),
1188    assert_cyclic(failed(Unit, Name, Line, E)).
1189
1190%!  assert_cyclic(+Term) is det.
1191%
1192%   Assert  a  possibly  cyclic  unit   clause.  Current  SWI-Prolog
1193%   assert/1 does not handle cyclic terms,  so we emulate this using
1194%   the recorded database.
1195%
1196%   @tbd    Implement cycle-safe assert and remove this.
1197
1198:- if(swi).
1199assert_cyclic(Term) :-
1200    acyclic_term(Term),
1201    !,
1202    assert(Term).
1203assert_cyclic(Term) :-
1204    Term =.. [Functor|Args],
1205    recorda(cyclic, Args, Id),
1206    functor(Term, _, Arity),
1207    length(NewArgs, Arity),
1208    Head =.. [Functor|NewArgs],
1209    assert((Head :- recorded(_, Var, Id), Var = NewArgs)).
1210:- else.
1211:- if(sicstus).
1212:- endif.
1213assert_cyclic(Term) :-
1214    assert(Term).
1215:- endif.
1216
1217
1218                 /*******************************
1219                 *            REPORTING         *
1220                 *******************************/
1221
1222%!  begin_test(Unit, Test, Line, STO) is det.
1223%!  end_test(Unit, Test, Line, STO) is det.
1224%
1225%   Maintain running/5 and report a test has started/is ended using
1226%   a =silent= message:
1227%
1228%       * plunit(begin(Unit:Test, File:Line, STO))
1229%       * plunit(end(Unit:Test, File:Line, STO))
1230%
1231%   @see message_hook/3 for intercepting these messages
1232
1233begin_test(Unit, Test, Line, STO) :-
1234    thread_self(Me),
1235    assert(running(Unit, Test, Line, STO, Me)),
1236    unit_file(Unit, File),
1237    print_message(silent, plunit(begin(Unit:Test, File:Line, STO))).
1238
1239end_test(Unit, Test, Line, STO) :-
1240    thread_self(Me),
1241    retractall(running(_,_,_,_,Me)),
1242    unit_file(Unit, File),
1243    print_message(silent, plunit(end(Unit:Test, File:Line, STO))).
1244
1245%!  running_tests is det.
1246%
1247%   Print the currently running test.
1248
1249running_tests :-
1250    running_tests(Running),
1251    print_message(informational, plunit(running(Running))).
1252
1253running_tests(Running) :-
1254    findall(running(Unit:Test, File:Line, STO, Thread),
1255            (   running(Unit, Test, Line, STO, Thread),
1256                unit_file(Unit, File)
1257            ), Running).
1258
1259
1260%!  check_for_test_errors is semidet.
1261%
1262%   True if there are no errors, otherwise false.
1263
1264check_for_test_errors :-
1265    number_of_clauses(failed/4, Failed),
1266    number_of_clauses(failed_assertion/7, FailedAssertion),
1267    number_of_clauses(sto/4, STO),
1268    Failed+FailedAssertion+STO =:= 0.     % fail on errors
1269
1270
1271%!  report is det.
1272%
1273%   Print a summary of the tests that ran.
1274
1275report :-
1276    number_of_clauses(passed/5, Passed),
1277    number_of_clauses(failed/4, Failed),
1278    number_of_clauses(failed_assertion/7, FailedAssertion),
1279    number_of_clauses(blocked/4, Blocked),
1280    number_of_clauses(sto/4, STO),
1281    (   Passed+Failed+FailedAssertion+Blocked+STO =:= 0
1282    ->  info(plunit(no_tests))
1283    ;   Failed+FailedAssertion+Blocked+STO =:= 0
1284    ->  report_fixme,
1285        info(plunit(all_passed(Passed)))
1286    ;   report_blocked,
1287        report_fixme,
1288        report_failed_assertions,
1289        report_failed,
1290        report_sto,
1291        info(plunit(passed(Passed)))
1292    ).
1293
1294number_of_clauses(F/A,N) :-
1295    (   current_predicate(F/A)
1296    ->  functor(G,F,A),
1297        findall(t, G, Ts),
1298        length(Ts, N)
1299    ;   N = 0
1300    ).
1301
1302report_blocked :-
1303    number_of_clauses(blocked/4,N),
1304    N > 0,
1305    !,
1306    info(plunit(blocked(N))),
1307    (   blocked(Unit, Name, Line, Reason),
1308        unit_file(Unit, File),
1309        print_message(informational,
1310                      plunit(blocked(File:Line, Name, Reason))),
1311        fail ; true
1312    ).
1313report_blocked.
1314
1315report_failed :-
1316    number_of_clauses(failed/4, N),
1317    info(plunit(failed(N))).
1318
1319report_failed_assertions :-
1320    number_of_clauses(failed_assertion/7, N),
1321    info(plunit(failed_assertions(N))).
1322
1323report_sto :-
1324    number_of_clauses(sto/4, N),
1325    info(plunit(sto(N))).
1326
1327report_fixme :-
1328    report_fixme(_,_,_).
1329
1330report_fixme(TuplesF, TuplesP, TuplesN) :-
1331    fixme(failed, TuplesF, Failed),
1332    fixme(passed, TuplesP, Passed),
1333    fixme(nondet, TuplesN, Nondet),
1334    print_message(informational, plunit(fixme(Failed, Passed, Nondet))).
1335
1336
1337fixme(How, Tuples, Count) :-
1338    findall(fixme(Unit, Name, Line, Reason, How),
1339            fixme(Unit, Name, Line, Reason, How), Tuples),
1340    length(Tuples, Count).
1341
1342
1343report_failure(_, _, _, assertion, _) :-
1344    !,
1345    put_char(user_error, 'A').
1346report_failure(Unit, Name, Line, Error, _Options) :-
1347    print_message(error, plunit(failed(Unit, Name, Line, Error))).
1348
1349
1350%!  test_report(What) is det.
1351%
1352%   Produce reports on test results after the run.
1353
1354test_report(fixme) :-
1355    !,
1356    report_fixme(TuplesF, TuplesP, TuplesN),
1357    append([TuplesF, TuplesP, TuplesN], Tuples),
1358    print_message(informational, plunit(fixme(Tuples))).
1359test_report(What) :-
1360    throw_error(domain_error(report_class, What), _).
1361
1362
1363                 /*******************************
1364                 *             INFO             *
1365                 *******************************/
1366
1367%!  current_test_set(?Unit) is nondet.
1368%
1369%   True if Unit is a currently loaded test-set.
1370
1371current_test_set(Unit) :-
1372    current_unit(Unit, _Module, _Context, _Options).
1373
1374%!  unit_file(+Unit, -File) is det.
1375%!  unit_file(-Unit, +File) is nondet.
1376
1377unit_file(Unit, File) :-
1378    current_unit(Unit, Module, _Context, _Options),
1379    current_module(Module, File).
1380unit_file(Unit, PlFile) :-
1381    nonvar(PlFile),
1382    test_file_for(TestFile, PlFile),
1383    current_module(Module, TestFile),
1384    current_unit(Unit, Module, _Context, _Options).
1385
1386
1387                 /*******************************
1388                 *             FILES            *
1389                 *******************************/
1390
1391%!  load_test_files(+Options) is det.
1392%
1393%   Load .plt test-files related to loaded source-files.
1394
1395load_test_files(_Options) :-
1396    (   source_file(File),
1397        file_name_extension(Base, Old, File),
1398        Old \== plt,
1399        file_name_extension(Base, plt, TestFile),
1400        exists_file(TestFile),
1401        (   test_file_for(TestFile, File)
1402        ->  true
1403        ;   load_files(TestFile,
1404                       [ if(changed),
1405                         imports([])
1406                       ]),
1407            asserta(test_file_for(TestFile, File))
1408        ),
1409        fail ; true
1410    ).
1411
1412
1413
1414                 /*******************************
1415                 *           MESSAGES           *
1416                 *******************************/
1417
1418%!  info(+Term)
1419%
1420%   Runs print_message(Level, Term), where Level  is one of =silent=
1421%   or =informational= (default).
1422
1423info(Term) :-
1424    message_level(Level),
1425    print_message(Level, Term).
1426
1427message_level(Level) :-
1428    current_test_flag(test_options, Options),
1429    option(silent(Silent), Options, false),
1430    (   Silent == false
1431    ->  Level = informational
1432    ;   Level = silent
1433    ).
1434
1435locationprefix(File:Line) -->
1436    !,
1437    [ '~w:~d:\n\t'-[File,Line]].
1438locationprefix(test(Unit,_Test,Line)) -->
1439    !,
1440    { unit_file(Unit, File) },
1441    locationprefix(File:Line).
1442locationprefix(unit(Unit)) -->
1443    !,
1444    [ 'PL-Unit: unit ~w: '-[Unit] ].
1445locationprefix(FileLine) -->
1446    { throw_error(type_error(locationprefix,FileLine), _) }.
1447
1448:- discontiguous
1449    message//1.
1450
1451message(error(context_error(plunit_close(Name, -)), _)) -->
1452    [ 'PL-Unit: cannot close unit ~w: no open unit'-[Name] ].
1453message(error(context_error(plunit_close(Name, Start)), _)) -->
1454    [ 'PL-Unit: cannot close unit ~w: current unit is ~w'-[Name, Start] ].
1455message(plunit(nondet(File, Line, Name))) -->
1456    locationprefix(File:Line),
1457    [ 'PL-Unit: Test ~w: Test succeeded with choicepoint'- [Name] ].
1458message(error(plunit(incompatible_options, Tests), _)) -->
1459    [ 'PL-Unit: incompatible test-options: ~p'-[Tests] ].
1460
1461                                        % Unit start/end
1462:- if(swi).
1463message(plunit(begin(Unit))) -->
1464    [ 'PL-Unit: ~w '-[Unit], flush ].
1465message(plunit(end(_Unit))) -->
1466    [ at_same_line, ' done' ].
1467:- else.
1468message(plunit(begin(Unit))) -->
1469    [ 'PL-Unit: ~w '-[Unit]/*, flush-[]*/ ].
1470message(plunit(end(_Unit))) -->
1471    [ ' done'-[] ].
1472:- endif.
1473message(plunit(blocked(unit(Unit, Reason)))) -->
1474    [ 'PL-Unit: ~w blocked: ~w'-[Unit, Reason] ].
1475message(plunit(running([]))) -->
1476    !,
1477    [ 'PL-Unit: no tests running' ].
1478message(plunit(running([One]))) -->
1479    !,
1480    [ 'PL-Unit: running ' ],
1481    running(One).
1482message(plunit(running(More))) -->
1483    !,
1484    [ 'PL-Unit: running tests:', nl ],
1485    running(More).
1486message(plunit(fixme([]))) --> !.
1487message(plunit(fixme(Tuples))) -->
1488    !,
1489    fixme_message(Tuples).
1490
1491                                        % Blocked tests
1492message(plunit(blocked(1))) -->
1493    !,
1494    [ 'one test is blocked:'-[] ].
1495message(plunit(blocked(N))) -->
1496    [ '~D tests are blocked:'-[N] ].
1497message(plunit(blocked(Pos, Name, Reason))) -->
1498    locationprefix(Pos),
1499    test_name(Name),
1500    [ ': ~w'-[Reason] ].
1501
1502                                        % fail/success
1503message(plunit(no_tests)) -->
1504    !,
1505    [ 'No tests to run' ].
1506message(plunit(all_passed(1))) -->
1507    !,
1508    [ 'test passed' ].
1509message(plunit(all_passed(Count))) -->
1510    !,
1511    [ 'All ~D tests passed'-[Count] ].
1512message(plunit(passed(Count))) -->
1513    !,
1514    [ '~D tests passed'-[Count] ].
1515message(plunit(failed(0))) -->
1516    !,
1517    [].
1518message(plunit(failed(1))) -->
1519    !,
1520    [ '1 test failed'-[] ].
1521message(plunit(failed(N))) -->
1522    [ '~D tests failed'-[N] ].
1523message(plunit(failed_assertions(0))) -->
1524    !,
1525    [].
1526message(plunit(failed_assertions(1))) -->
1527    !,
1528    [ '1 assertion failed'-[] ].
1529message(plunit(failed_assertions(N))) -->
1530    [ '~D assertions failed'-[N] ].
1531message(plunit(sto(0))) -->
1532    !,
1533    [].
1534message(plunit(sto(N))) -->
1535    [ '~D test results depend on unification mode'-[N] ].
1536message(plunit(fixme(0,0,0))) -->
1537    [].
1538message(plunit(fixme(Failed,0,0))) -->
1539    !,
1540    [ 'all ~D tests flagged FIXME failed'-[Failed] ].
1541message(plunit(fixme(Failed,Passed,0))) -->
1542    [ 'FIXME: ~D failed; ~D passed'-[Failed, Passed] ].
1543message(plunit(fixme(Failed,Passed,Nondet))) -->
1544    { TotalPassed is Passed+Nondet },
1545    [ 'FIXME: ~D failed; ~D passed; (~D nondet)'-
1546      [Failed, TotalPassed, Nondet] ].
1547message(plunit(failed(Unit, Name, Line, Failure))) -->
1548    { unit_file(Unit, File) },
1549    locationprefix(File:Line),
1550    test_name(Name),
1551    [': '-[] ],
1552    failure(Failure).
1553:- if(swi).
1554message(plunit(failed_assertion(Unit, Name, Line, AssertLoc,
1555                                _STO, Reason, Goal))) -->
1556    { unit_file(Unit, File) },
1557    locationprefix(File:Line),
1558    test_name(Name),
1559    [ ': assertion'-[] ],
1560    assertion_location(AssertLoc, File),
1561    assertion_reason(Reason), ['\n\t'],
1562    assertion_goal(Unit, Goal).
1563
1564assertion_location(File:Line, File) -->
1565    [ ' at line ~w'-[Line] ].
1566assertion_location(File:Line, _) -->
1567    [ ' at ~w:~w'-[File, Line] ].
1568assertion_location(unknown, _) -->
1569    [].
1570
1571assertion_reason(fail) -->
1572    !,
1573    [ ' failed'-[] ].
1574assertion_reason(Error) -->
1575    { message_to_string(Error, String) },
1576    [ ' raised "~w"'-[String] ].
1577
1578assertion_goal(Unit, Goal) -->
1579    { unit_module(Unit, Module),
1580      unqualify(Goal, Module, Plain)
1581    },
1582    [ 'Assertion: ~p'-[Plain] ].
1583
1584unqualify(Var, _, Var) :-
1585    var(Var),
1586    !.
1587unqualify(M:Goal, Unit, Goal) :-
1588    nonvar(M),
1589    unit_module(Unit, M),
1590    !.
1591unqualify(M:Goal, _, Goal) :-
1592    callable(Goal),
1593    predicate_property(M:Goal, imported_from(system)),
1594    !.
1595unqualify(Goal, _, Goal).
1596
1597:- endif.
1598                                        % Setup/condition errors
1599message(plunit(error(Where, Context, Exception))) -->
1600    locationprefix(Context),
1601    { message_to_string(Exception, String) },
1602    [ 'error in ~w: ~w'-[Where, String] ].
1603
1604                                        % STO messages
1605message(plunit(sto(Unit, Name, Line))) -->
1606    { unit_file(Unit, File) },
1607       locationprefix(File:Line),
1608       test_name(Name),
1609       [' is subject to occurs check (STO): '-[] ].
1610message(plunit(sto(Type, Result))) -->
1611    sto_type(Type),
1612    sto_result(Result).
1613
1614                                        % Interrupts (SWI)
1615:- if(swi).
1616message(interrupt(begin)) -->
1617    { thread_self(Me),
1618      running(Unit, Test, Line, STO, Me),
1619      !,
1620      unit_file(Unit, File)
1621    },
1622    [ 'Interrupted test '-[] ],
1623    running(running(Unit:Test, File:Line, STO, Me)),
1624    [nl],
1625    '$messages':prolog_message(interrupt(begin)).
1626message(interrupt(begin)) -->
1627    '$messages':prolog_message(interrupt(begin)).
1628:- endif.
1629
1630test_name(@(Name,Bindings)) -->
1631    !,
1632    [ 'test ~w (forall bindings = ~p)'-[Name, Bindings] ].
1633test_name(Name) -->
1634    !,
1635    [ 'test ~w'-[Name] ].
1636
1637sto_type(sto_error_incomplete) -->
1638    [ 'Finite trees (error checking): ' ].
1639sto_type(rational_trees) -->
1640    [ 'Rational trees: ' ].
1641sto_type(finite_trees) -->
1642    [ 'Finite trees: ' ].
1643
1644sto_result(success(_Unit, _Name, _Line, Det, Time)) -->
1645    det(Det),
1646    [ ' success in ~2f seconds'-[Time] ].
1647sto_result(failure(_Unit, _Name, _Line, How)) -->
1648    failure(How).
1649
1650det(true) -->
1651    [ 'deterministic' ].
1652det(false) -->
1653    [ 'non-deterministic' ].
1654
1655running(running(Unit:Test, File:Line, STO, Thread)) -->
1656    thread(Thread),
1657    [ '~q:~q at ~w:~d'-[Unit, Test, File, Line] ],
1658    current_sto(STO).
1659running([H|T]) -->
1660    ['\t'], running(H),
1661    (   {T == []}
1662    ->  []
1663    ;   [nl], running(T)
1664    ).
1665
1666thread(main) --> !.
1667thread(Other) -->
1668    [' [~w] '-[Other] ].
1669
1670current_sto(sto_error_incomplete) -->
1671    [ ' (STO: error checking)' ].
1672current_sto(rational_trees) -->
1673    [].
1674current_sto(finite_trees) -->
1675    [ ' (STO: occurs check enabled)' ].
1676
1677:- if(swi).
1678write_term(T, OPS) -->
1679    ['~@'-[write_term(T,OPS)]].
1680:- else.
1681write_term(T, _OPS) -->
1682    ['~q'-[T]].
1683:- endif.
1684
1685expected_got_ops_(Ex, E, OPS, Goals) -->
1686    ['    Expected: '-[]], write_term(Ex, OPS), [nl],
1687    ['    Got:      '-[]], write_term(E,  OPS), [nl],
1688    ( { Goals = [] } -> []
1689    ; ['       with: '-[]], write_term(Goals, OPS), [nl]
1690    ).
1691
1692
1693failure(Var) -->
1694    { var(Var) },
1695    !,
1696    [ 'Unknown failure?' ].
1697failure(succeeded(Time)) -->
1698    !,
1699    [ 'must fail but succeeded in ~2f seconds~n'-[Time] ].
1700failure(wrong_error(Expected, Error)) -->
1701    !,
1702    { copy_term(Expected-Error, Ex-E, Goals),
1703      numbervars(Ex-E-Goals, 0, _),
1704      write_options(OPS)
1705    },
1706    [ 'wrong error'-[], nl ],
1707    expected_got_ops_(Ex, E, OPS, Goals).
1708failure(wrong_answer(Cmp)) -->
1709    { Cmp =.. [Op,Answer,Expected],
1710      !,
1711      copy_term(Expected-Answer, Ex-A, Goals),
1712      numbervars(Ex-A-Goals, 0, _),
1713      write_options(OPS)
1714    },
1715    [ 'wrong answer (compared using ~w)'-[Op], nl ],
1716    expected_got_ops_(Ex, A, OPS, Goals).
1717failure(wrong_answer(CmpExpected, Bindings)) -->
1718    { (   CmpExpected = all(Cmp)
1719      ->  Cmp =.. [_Op1,_,Expected],
1720          Got = Bindings,
1721          Type = all
1722      ;   CmpExpected = set(Cmp),
1723          Cmp =.. [_Op2,_,Expected0],
1724          sort(Expected0, Expected),
1725          sort(Bindings, Got),
1726          Type = set
1727      )
1728    },
1729    [ 'wrong "~w" answer:'-[Type] ],
1730    [ nl, '    Expected: ~q'-[Expected] ],
1731    [ nl, '       Found: ~q'-[Got] ].
1732:- if(swi).
1733failure(cmp_error(_Cmp, Error)) -->
1734    { message_to_string(Error, Message) },
1735    [ 'Comparison error: ~w'-[Message] ].
1736failure(Error) -->
1737    { Error = error(_,_),
1738      !,
1739      message_to_string(Error, Message)
1740    },
1741    [ 'received error: ~w'-[Message] ].
1742:- endif.
1743failure(Why) -->
1744    [ '~p~n'-[Why] ].
1745
1746fixme_message([]) --> [].
1747fixme_message([fixme(Unit, _Name, Line, Reason, How)|T]) -->
1748    { unit_file(Unit, File) },
1749    fixme_message(File:Line, Reason, How),
1750    (   {T == []}
1751    ->  []
1752    ;   [nl],
1753        fixme_message(T)
1754    ).
1755
1756fixme_message(Location, Reason, failed) -->
1757    [ 'FIXME: ~w: ~w'-[Location, Reason] ].
1758fixme_message(Location, Reason, passed) -->
1759    [ 'FIXME: ~w: passed ~w'-[Location, Reason] ].
1760fixme_message(Location, Reason, nondet) -->
1761    [ 'FIXME: ~w: passed (nondet) ~w'-[Location, Reason] ].
1762
1763
1764write_options([ numbervars(true),
1765                quoted(true),
1766                portray(true),
1767                max_depth(10),
1768                attributes(portray)
1769              ]).
1770
1771:- if(swi).
1772
1773:- multifile
1774    prolog:message/3,
1775    user:message_hook/3.
1776
1777prolog:message(Term) -->
1778    message(Term).
1779
1780%       user:message_hook(+Term, +Kind, +Lines)
1781
1782user:message_hook(make(done(Files)), _, _) :-
1783    make_run_tests(Files),
1784    fail.                           % give other hooks a chance
1785
1786:- endif.
1787
1788:- if(sicstus).
1789
1790user:generate_message_hook(Message) -->
1791    message(Message),
1792    [nl].                           % SICStus requires nl at the end
1793
1794%!  user:message_hook(+Severity, +Message, +Lines) is semidet.
1795%
1796%   Redefine printing some messages. It appears   SICStus has no way
1797%   to get multiple messages at the same   line, so we roll our own.
1798%   As there is a lot pre-wired and   checked in the SICStus message
1799%   handling we cannot reuse the lines. Unless I miss something ...
1800
1801user:message_hook(informational, plunit(begin(Unit)), _Lines) :-
1802    format(user_error, '% PL-Unit: ~w ', [Unit]),
1803    flush_output(user_error).
1804user:message_hook(informational, plunit(end(_Unit)), _Lines) :-
1805    format(user, ' done~n', []).
1806
1807:- endif.