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-2020, University of Amsterdam
    7                              VU University Amsterdam
    8                              CWI, Amsterdam
    9    All rights reserved.
   10
   11    Redistribution and use in source and binary forms, with or without
   12    modification, are permitted provided that the following conditions
   13    are met:
   14
   15    1. Redistributions of source code must retain the above copyright
   16       notice, this list of conditions and the following disclaimer.
   17
   18    2. Redistributions in binary form must reproduce the above copyright
   19       notice, this list of conditions and the following disclaimer in
   20       the documentation and/or other materials provided with the
   21       distribution.
   22
   23    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   24    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   25    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   26    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   27    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   28    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   29    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   30    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   31    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   32    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   33    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   34    POSSIBILITY OF SUCH DAMAGE.
   35*/
   36
   37:- module(plunit,
   38          [ set_test_options/1,         % +Options
   39            begin_tests/1,              % +Name
   40            begin_tests/2,              % +Name, +Options
   41            end_tests/1,                % +Name
   42            run_tests/0,                % Run all tests
   43            run_tests/1,                % Run named test-set
   44            load_test_files/1,          % +Options
   45            running_tests/0,            % Prints currently running test
   46            current_test/5,             % ?Unit,?Test,?Line,?Body,?Options
   47            test_report/1               % +What
   48          ]).

   56:- autoload(library(apply), [maplist/3,include/3]).   57:- autoload(library(lists), [member/2,append/2]).   58:- autoload(library(option), [option/3,option/2]).   59:- autoload(library(ordsets), [ord_intersection/3]).   60:- autoload(library(pairs), [group_pairs_by_key/2,pairs_values/2]).   61:- autoload(library(error), [must_be/2]).   62:- autoload(library(thread), [concurrent_forall/2]).   63
   64:- meta_predicate valid_options(+, 1).   65
   66
   67                 /*******************************
   68                 *    CONDITIONAL COMPILATION   *
   69                 *******************************/
   70
   71:- discontiguous
   72    user:term_expansion/2.   73
   74:- dynamic
   75    include_code/1.   76
   77including :-
   78    include_code(X),
   79    !,
   80    X == true.
   81including.
   82
   83if_expansion((:- if(G)), []) :-
   84    (   including
   85    ->  (   catch(G, E, (print_message(error, E), fail))
   86        ->  asserta(include_code(true))
   87        ;   asserta(include_code(false))
   88        )
   89    ;   asserta(include_code(else_false))
   90    ).
   91if_expansion((:- else), []) :-
   92    (   retract(include_code(X))
   93    ->  (   X == true
   94        ->  X2 = false
   95        ;   X == false
   96        ->  X2 = true
   97        ;   X2 = X
   98        ),
   99        asserta(include_code(X2))
  100    ;   throw_error(context_error(no_if),_)
  101    ).
  102if_expansion((:- endif), []) :-
  103    retract(include_code(_)),
  104    !.
  105
  106if_expansion(_, []) :-
  107    \+ including.
  108
  109user:term_expansion(In, Out) :-
  110    prolog_load_context(module, plunit),
  111    if_expansion(In, Out).
  112
  113swi     :- catch(current_prolog_flag(dialect, swi), _, fail), !.
  114swi     :- catch(current_prolog_flag(dialect, yap), _, fail).
  115sicstus :- catch(current_prolog_flag(system_type, _), _, fail).
  116
  117
  118:- if(swi).  119throw_error(Error_term,Impldef) :-
  120    throw(error(Error_term,context(Impldef,_))).
  121
  122:- set_prolog_flag(generate_debug_info, false).  123current_test_flag(Name, Value) :-
  124    current_prolog_flag(Name, Value).
  125
  126set_test_flag(Name, Value) :-
  127    create_prolog_flag(Name, Value, []).
  128
  129% ensure expansion to avoid tracing
  130goal_expansion(forall(C,A),
  131               \+ (C, \+ A)).
  132goal_expansion(current_module(Module,File),
  133               module_property(Module, file(File))).
  134
  135:- if(current_prolog_flag(dialect, yap)).  136
  137'$set_predicate_attribute'(_, _, _).
  138
  139:- endif.  140:- endif.  141
  142:- if(sicstus).  143throw_error(Error_term,Impldef) :-
  144    throw(error(Error_term,i(Impldef))). % SICStus 3 work around
  145
  146% SWI-Compatibility
  147:- op(700, xfx, =@=).  148
  149'$set_source_module'(_, _).

 current_test_flag(?Name, ?Value) is nondet

Query flags that control the testing process. Emulates SWI-Prologs flags.

  156:- dynamic test_flag/2. % Name, Val
  157
  158current_test_flag(optimise, Val) :-
  159    current_prolog_flag(compiling, Compiling),
  160    (   Compiling == debugcode ; true % TBD: Proper test
  161    ->  Val = false
  162    ;   Val = true
  163    ).
  164current_test_flag(Name, Val) :-
  165    test_flag(Name, Val).

 set_test_flag(+Name, +Value) is det

  170set_test_flag(Name, Val) :-
  171    var(Name),
  172    !,
  173    throw_error(instantiation_error, set_test_flag(Name,Val)).
  174set_test_flag( Name, Val ) :-
  175    retractall(test_flag(Name,_)),
  176    asserta(test_flag(Name, Val)).
  177
  178:- op(1150, fx, thread_local).  179
  180user:term_expansion((:- thread_local(PI)), (:- dynamic(PI))) :-
  181    prolog_load_context(module, plunit).
  182
  183:- endif.  184
  185                 /*******************************
  186                 *            IMPORTS           *
  187                 *******************************/
  188
  189:- initialization
  190   (   current_test_flag(test_options, _)
  191   ->  true
  192   ;   set_test_flag(test_options,
  193                 [ run(make),       % run tests on make/0
  194                   sto(false)
  195                 ])
  196   ).

 set_test_options(+Options)

Specifies how to deal with test suites. Defined options are:

load(+Load)

Whether or not the tests must be loaded. Values are never, always, normal (only if not optimised)

run(+When)

When the tests are run. Values are manual, make or make(all).

silent(+Bool)

If true (default false), report successful tests using message level silent, only printing errors and warnings.

sto(+Bool)

How to test whether code is subject to occurs check (STO). If false (default), STO is not considered. If true and supported by the hosting Prolog, code is run in all supported unification mode and reported if the results are inconsistent.

cleanup(+Bool)

If true (default =false), cleanup report at the end of run_tests/1. Used to improve cooperation with memory debuggers such as dmalloc.

concurrent(+Bool)

If true (default =false), run all tests in a block concurrently.

  232set_test_options(Options) :-
  233    valid_options(Options, global_test_option),
  234    set_test_flag(test_options, Options).
  235
  236global_test_option(load(Load)) :-
  237    must_be(oneof([never,always,normal]), Load).
  238global_test_option(run(When)) :-
  239    must_be(oneof([manual,make,make(all)]), When).
  240global_test_option(silent(Bool)) :-
  241    must_be(boolean, Bool).
  242global_test_option(sto(Bool)) :-
  243    must_be(boolean, Bool).
  244global_test_option(cleanup(Bool)) :-
  245    must_be(boolean, Bool).
  246global_test_option(concurrent(Bool)) :-
  247    must_be(boolean, Bool).

 loading_tests

True if tests must be loaded.

  254loading_tests :-
  255    current_test_flag(test_options, Options),
  256    option(load(Load), Options, normal),
  257    (   Load == always
  258    ->  true
  259    ;   Load == normal,
  260        \+ current_test_flag(optimise, true)
  261    ).
  262
  263                 /*******************************
  264                 *            MODULE            *
  265                 *******************************/
  266
  267:- dynamic
  268    loading_unit/4,                 % Unit, Module, File, OldSource
  269    current_unit/4,                 % Unit, Module, Context, Options
  270    test_file_for/2.                % ?TestFile, ?PrologFile

 begin_tests(+UnitName:atom) is det

 begin_tests(+UnitName:atom, Options) is det

Start a test-unit. UnitName is the name of the test set. the unit is ended by :- end_tests(UnitName).

  278begin_tests(Unit) :-
  279    begin_tests(Unit, []).
  280
  281begin_tests(Unit, Options) :-
  282    valid_options(Options, test_set_option),
  283    make_unit_module(Unit, Name),
  284    source_location(File, Line),
  285    begin_tests(Unit, Name, File:Line, Options).
  286
  287:- if(swi).  288begin_tests(Unit, Name, File:Line, Options) :-
  289    loading_tests,
  290    !,
  291    '$set_source_module'(Context, Context),
  292    (   current_unit(Unit, Name, Context, Options)
  293    ->  true
  294    ;   retractall(current_unit(Unit, Name, _, _)),
  295        assert(current_unit(Unit, Name, Context, Options))
  296    ),
  297    '$set_source_module'(Old, Name),
  298    '$declare_module'(Name, test, Context, File, Line, false),
  299    discontiguous(Name:'unit test'/4),
  300    '$set_predicate_attribute'(Name:'unit test'/4, trace, false),
  301    discontiguous(Name:'unit body'/2),
  302    asserta(loading_unit(Unit, Name, File, Old)).
  303begin_tests(Unit, Name, File:_Line, _Options) :-
  304    '$set_source_module'(Old, Old),
  305    asserta(loading_unit(Unit, Name, File, Old)).
  306
  307:- else.  308
  309% we cannot use discontiguous as a goal in SICStus Prolog.
  310
  311user:term_expansion((:- begin_tests(Set)),
  312                    [ (:- begin_tests(Set)),
  313                      (:- discontiguous(test/2)),
  314                      (:- discontiguous('unit body'/2)),
  315                      (:- discontiguous('unit test'/4))
  316                    ]).
  317
  318begin_tests(Unit, Name, File:_Line, Options) :-
  319    loading_tests,
  320    !,
  321    (   current_unit(Unit, Name, _, Options)
  322    ->  true
  323    ;   retractall(current_unit(Unit, Name, _, _)),
  324        assert(current_unit(Unit, Name, -, Options))
  325    ),
  326    asserta(loading_unit(Unit, Name, File, -)).
  327begin_tests(Unit, Name, File:_Line, _Options) :-
  328    asserta(loading_unit(Unit, Name, File, -)).
  329
  330:- endif.

 end_tests(+Name) is det

Close a unit-test module.

To be done

- Run tests/clean module?

- End of file?

  339end_tests(Unit) :-
  340    loading_unit(StartUnit, _, _, _),
  341    !,
  342    (   Unit == StartUnit
  343    ->  once(retract(loading_unit(StartUnit, _, _, Old))),
  344        '$set_source_module'(_, Old)
  345    ;   throw_error(context_error(plunit_close(Unit, StartUnit)), _)
  346    ).
  347end_tests(Unit) :-
  348    throw_error(context_error(plunit_close(Unit, -)), _).

 make_unit_module(+Name, -ModuleName) is det

 unit_module(+Name, -ModuleName) is det

  353:- if(swi).  354
  355unit_module(Unit, Module) :-
  356    atom_concat('plunit_', Unit, Module).
  357
  358make_unit_module(Unit, Module) :-
  359    unit_module(Unit, Module),
  360    (   current_module(Module),
  361        \+ current_unit(_, Module, _, _),
  362        predicate_property(Module:H, _P),
  363        \+ predicate_property(Module:H, imported_from(_M))
  364    ->  throw_error(permission_error(create, plunit, Unit),
  365                    'Existing module')
  366    ;  true
  367    ).
  368
  369:- else.  370
  371:- dynamic
  372    unit_module_store/2.  373
  374unit_module(Unit, Module) :-
  375    unit_module_store(Unit, Module),
  376    !.
  377
  378make_unit_module(Unit, Module) :-
  379    prolog_load_context(module, Module),
  380    assert(unit_module_store(Unit, Module)).
  381
  382:- endif.  383
  384                 /*******************************
  385                 *           EXPANSION          *
  386                 *******************************/

 expand_test(+Name, +Options, +Body, -Clause) is det

Expand test(Name, Options) :- Body into a clause for 'unit test'/4 and 'unit body'/2.

  393expand_test(Name, Options0, Body,
  394            [ 'unit test'(Name, Line, Options, Module:'unit body'(Id, Vars)),
  395              ('unit body'(Id, Vars) :- !, Body)
  396            ]) :-
  397    source_location(_File, Line),
  398    prolog_load_context(module, Module),
  399    atomic_list_concat([Name, '@line ', Line], Id),
  400    term_variables(Options0, OptionVars0), sort(OptionVars0, OptionVars),
  401    term_variables(Body, BodyVars0), sort(BodyVars0, BodyVars),
  402    ord_intersection(OptionVars, BodyVars, VarList),
  403    Vars =.. [vars|VarList],
  404    (   is_list(Options0)           % allow for single option without list
  405    ->  Options1 = Options0
  406    ;   Options1 = [Options0]
  407    ),
  408    maplist(expand_option, Options1, Options2),
  409    valid_options(Options2, test_option),
  410    valid_test_mode(Options2, Options).
  411
  412expand_option(Var, _) :-
  413    var(Var),
  414    !,
  415    throw_error(instantiation_error,_).
  416expand_option(A == B, true(A==B)) :- !.
  417expand_option(A = B, true(A=B)) :- !.
  418expand_option(A =@= B, true(A=@=B)) :- !.
  419expand_option(A =:= B, true(A=:=B)) :- !.
  420expand_option(error(X), throws(error(X, _))) :- !.
  421expand_option(exception(X), throws(X)) :- !. % SICStus 4 compatibility
  422expand_option(error(F,C), throws(error(F,C))) :- !. % SICStus 4 compatibility
  423expand_option(true, true(true)) :- !.
  424expand_option(O, O).
  425
  426valid_test_mode(Options0, Options) :-
  427    include(test_mode, Options0, Tests),
  428    (   Tests == []
  429    ->  Options = [true(true)|Options0]
  430    ;   Tests = [_]
  431    ->  Options = Options0
  432    ;   throw_error(plunit(incompatible_options, Tests), _)
  433    ).
  434
  435test_mode(true(_)).
  436test_mode(all(_)).
  437test_mode(set(_)).
  438test_mode(fail).
  439test_mode(throws(_)).

 expand(+Term, -Clauses) is semidet

  444expand(end_of_file, _) :-
  445    loading_unit(Unit, _, _, _),
  446    !,
  447    end_tests(Unit),                % warn?
  448    fail.
  449expand((:-end_tests(_)), _) :-
  450    !,
  451    fail.
  452expand(_Term, []) :-
  453    \+ loading_tests.
  454expand((test(Name) :- Body), Clauses) :-
  455    !,
  456    expand_test(Name, [], Body, Clauses).
  457expand((test(Name, Options) :- Body), Clauses) :-
  458    !,
  459    expand_test(Name, Options, Body, Clauses).
  460expand(test(Name), _) :-
  461    !,
  462    throw_error(existence_error(body, test(Name)), _).
  463expand(test(Name, _Options), _) :-
  464    !,
  465    throw_error(existence_error(body, test(Name)), _).
  466
  467:- if(swi).  468:- multifile
  469    system:term_expansion/2.  470:- endif.  471
  472system:term_expansion(Term, Expanded) :-
  473    (   loading_unit(_, _, File, _)
  474    ->  source_location(File, _),
  475        expand(Term, Expanded)
  476    ).
  477
  478
  479                 /*******************************
  480                 *             OPTIONS          *
  481                 *******************************/
  482
  483:- if(swi).  484:- else.  485must_be(list, X) :-
  486    !,
  487    (   is_list(X)
  488    ->  true
  489    ;   is_not(list, X)
  490    ).
  491must_be(Type, X) :-
  492    (   call(Type, X)
  493    ->  true
  494    ;   is_not(Type, X)
  495    ).
  496
  497is_not(Type, X) :-
  498    (   ground(X)
  499    ->  throw_error(type_error(Type, X), _)
  500    ;   throw_error(instantiation_error, _)
  501    ).
  502:- endif.

 valid_options(+Options, :Pred) is det

Verify Options to be a list of valid options according to Pred.

throws

- type_error or instantiation_error.

  511valid_options(Options, Pred) :-
  512    must_be(list, Options),
  513    verify_options(Options, Pred).
  514
  515verify_options([], _).
  516verify_options([H|T], Pred) :-
  517    (   call(Pred, H)
  518    ->  verify_options(T, Pred)
  519    ;   throw_error(domain_error(Pred, H), _)
  520    ).

 test_option(+Option) is semidet

True if Option is a valid option for test(Name, Options).

  527test_option(Option) :-
  528    test_set_option(Option),
  529    !.
  530test_option(true(_)).
  531test_option(fail).
  532test_option(throws(_)).
  533test_option(all(_)).
  534test_option(set(_)).
  535test_option(nondet).
  536test_option(fixme(_)).
  537test_option(forall(X)) :-
  538    must_be(callable, X).

 test_option(+Option) is semidet

True if Option is a valid option for :- begin_tests(Name, Options).

  545test_set_option(blocked(X)) :-
  546    must_be(ground, X).
  547test_set_option(condition(X)) :-
  548    must_be(callable, X).
  549test_set_option(setup(X)) :-
  550    must_be(callable, X).
  551test_set_option(cleanup(X)) :-
  552    must_be(callable, X).
  553test_set_option(sto(V)) :-
  554    nonvar(V), member(V, [finite_trees, rational_trees]).
  555test_set_option(concurrent(V)) :-
  556    must_be(boolean, V).
  557
  558
  559                 /*******************************
  560                 *        RUNNING TOPLEVEL      *
  561                 *******************************/
  562
  563:- thread_local
  564    passed/5,                       % Unit, Test, Line, Det, Time
  565    failed/4,                       % Unit, Test, Line, Reason
  566    failed_assertion/7,             % Unit, Test, Line, ALoc, STO, Reason, Goal
  567    blocked/4,                      % Unit, Test, Line, Reason
  568    sto/4,                          % Unit, Test, Line, Results
  569    fixme/5.                        % Unit, Test, Line, Reason, Status
  570
  571:- dynamic
  572    running/5.                      % Unit, Test, Line, STO, Thread

 run_tests is semidet

 run_tests(+TestSet) is semidet

Run tests and report about the results. The predicate run_tests/0 runs all known tests that are not blocked. The predicate run_tests/1 takes a specification of tests to run. This is either a single specification or a list of specifications. Each single specification is either the name of a test-unit or a term <test-unit>:<test>, denoting a single test within a unit.

  585run_tests :-
  586    cleanup,
  587    setup_call_cleanup(
  588        setup_trap_assertions(Ref),
  589        run_current_units,
  590        report_and_cleanup(Ref)).
  591
  592run_current_units :-
  593    forall(current_test_set(Set),
  594           run_unit(Set)),
  595    check_for_test_errors.
  596
  597report_and_cleanup(Ref) :-
  598    cleanup_trap_assertions(Ref),
  599    report,
  600    cleanup_after_test.
  601
  602run_tests(Set) :-
  603    cleanup,
  604    setup_call_cleanup(
  605        setup_trap_assertions(Ref),
  606        run_unit_and_check_errors(Set),
  607        report_and_cleanup(Ref)).
  608
  609run_unit_and_check_errors(Set) :-
  610    run_unit(Set),
  611    check_for_test_errors.
  612
  613run_unit([]) :- !.
  614run_unit([H|T]) :-
  615    !,
  616    run_unit(H),
  617    run_unit(T).
  618run_unit(Spec) :-
  619    unit_from_spec(Spec, Unit, Tests, Module, UnitOptions),
  620    (   option(blocked(Reason), UnitOptions)
  621    ->  info(plunit(blocked(unit(Unit, Reason))))
  622    ;   setup(Module, unit(Unit), UnitOptions)
  623    ->  info(plunit(begin(Spec))),
  624        current_test_flag(test_options, GlobalOptions),
  625        (   option(concurrent(true), GlobalOptions),
  626            option(concurrent(true), UnitOptions, false)
  627        ->  concurrent_forall((Module:'unit test'(Name, Line, Options, Body),
  628                               matching_test(Name, Tests)),
  629                              run_test(Unit, Name, Line, Options, Body))
  630        ;   forall((Module:'unit test'(Name, Line, Options, Body),
  631                    matching_test(Name, Tests)),
  632                   run_test(Unit, Name, Line, Options, Body))),
  633        info(plunit(end(Spec))),
  634        (   message_level(silent)
  635        ->  true
  636        ;   format(user_error, '~N', [])
  637        ),
  638        cleanup(Module, UnitOptions)
  639    ;   true
  640    ).
  641
  642unit_from_spec(Unit, Unit, _, Module, Options) :-
  643    atom(Unit),
  644    !,
  645    (   current_unit(Unit, Module, _Supers, Options)
  646    ->  true
  647    ;   throw_error(existence_error(unit_test, Unit), _)
  648    ).
  649unit_from_spec(Unit:Tests, Unit, Tests, Module, Options) :-
  650    atom(Unit),
  651    !,
  652    (   current_unit(Unit, Module, _Supers, Options)
  653    ->  true
  654    ;   throw_error(existence_error(unit_test, Unit), _)
  655    ).
  656
  657
  658matching_test(X, X) :- !.
  659matching_test(Name, Set) :-
  660    is_list(Set),
  661    memberchk(Name, Set).
  662
  663cleanup :-
  664    thread_self(Me),
  665    retractall(passed(_, _, _, _, _)),
  666    retractall(failed(_, _, _, _)),
  667    retractall(failed_assertion(_, _, _, _, _, _, _)),
  668    retractall(blocked(_, _, _, _)),
  669    retractall(sto(_, _, _, _)),
  670    retractall(fixme(_, _, _, _, _)),
  671    retractall(running(_,_,_,_,Me)).
  672
  673cleanup_after_test :-
  674    current_test_flag(test_options, Options),
  675    option(cleanup(Cleanup), Options, false),
  676    (   Cleanup == true
  677    ->  cleanup
  678    ;   true
  679    ).

 run_tests_in_files(+Files:list) is det

Run all test-units that appear in the given Files.

  686run_tests_in_files(Files) :-
  687    findall(Unit, unit_in_files(Files, Unit), Units),
  688    (   Units == []
  689    ->  true
  690    ;   run_tests(Units)
  691    ).
  692
  693unit_in_files(Files, Unit) :-
  694    is_list(Files),
  695    !,
  696    member(F, Files),
  697    absolute_file_name(F, Source,
  698                       [ file_type(prolog),
  699                         access(read),
  700                         file_errors(fail)
  701                       ]),
  702    unit_file(Unit, Source).
  703
  704
  705                 /*******************************
  706                 *         HOOKING MAKE/0       *
  707                 *******************************/

 make_run_tests(+Files)

Called indirectly from make/0 after Files have been reloaded.

  713make_run_tests(Files) :-
  714    current_test_flag(test_options, Options),
  715    option(run(When), Options, manual),
  716    (   When == make
  717    ->  run_tests_in_files(Files)
  718    ;   When == make(all)
  719    ->  run_tests
  720    ;   true
  721    ).
  722
  723:- if(swi).  724
  725unification_capability(sto_error_incomplete).
  726% can detect some (almost all) STO runs
  727unification_capability(rational_trees).
  728unification_capability(finite_trees).
  729
  730set_unification_capability(Cap) :-
  731    cap_to_flag(Cap, Flag),
  732    set_prolog_flag(occurs_check, Flag).
  733
  734current_unification_capability(Cap) :-
  735    current_prolog_flag(occurs_check, Flag),
  736    cap_to_flag(Cap, Flag),
  737    !.
  738
  739cap_to_flag(sto_error_incomplete, error).
  740cap_to_flag(rational_trees, false).
  741cap_to_flag(finite_trees, true).
  742
  743:- else.  744:- if(sicstus).  745
  746unification_capability(rational_trees).
  747set_unification_capability(rational_trees).
  748current_unification_capability(rational_trees).
  749
  750:- else.  751
  752unification_capability(_) :-
  753    fail.
  754
  755:- endif.  756:- endif.  757
  758                 /*******************************
  759                 *      ASSERTION HANDLING      *
  760                 *******************************/
  761
  762:- if(swi).  763
  764:- dynamic prolog:assertion_failed/2.  765
  766setup_trap_assertions(Ref) :-
  767    asserta((prolog:assertion_failed(Reason, Goal) :-
  768                    test_assertion_failed(Reason, Goal)),
  769            Ref).
  770
  771cleanup_trap_assertions(Ref) :-
  772    erase(Ref).
  773
  774test_assertion_failed(Reason, Goal) :-
  775    thread_self(Me),
  776    running(Unit, Test, Line, STO, Me),
  777    (   catch(get_prolog_backtrace(10, Stack), _, fail),
  778        assertion_location(Stack, AssertLoc)
  779    ->  true
  780    ;   AssertLoc = unknown
  781    ),
  782    current_test_flag(test_options, Options),
  783    report_failed_assertion(Unit, Test, Line, AssertLoc,
  784                            STO, Reason, Goal, Options),
  785    assert_cyclic(failed_assertion(Unit, Test, Line, AssertLoc,
  786                                   STO, Reason, Goal)).
  787
  788assertion_location(Stack, File:Line) :-
  789    append(_, [AssertFrame,CallerFrame|_], Stack),
  790    prolog_stack_frame_property(AssertFrame,
  791                                predicate(prolog_debug:assertion/1)),
  792    !,
  793    prolog_stack_frame_property(CallerFrame, location(File:Line)).
  794
  795report_failed_assertion(Unit, Test, Line, AssertLoc,
  796                        STO, Reason, Goal, _Options) :-
  797    print_message(
  798        error,
  799        plunit(failed_assertion(Unit, Test, Line, AssertLoc,
  800                                STO, Reason, Goal))).
  801
  802:- else.  803
  804setup_trap_assertions(_).
  805cleanup_trap_assertions(_).
  806
  807:- endif.  808
  809
  810                 /*******************************
  811                 *         RUNNING A TEST       *
  812                 *******************************/

 run_test(+Unit, +Name, +Line, +Options, +Body) is det

Run a single test.

  818run_test(Unit, Name, Line, Options, Body) :-
  819    option(forall(Generator), Options),
  820    !,
  821    unit_module(Unit, Module),
  822    term_variables(Generator, Vars),
  823    forall(Module:Generator,
  824           run_test_once(Unit, @(Name,Vars), Line, Options, Body)).
  825run_test(Unit, Name, Line, Options, Body) :-
  826    run_test_once(Unit, Name, Line, Options, Body).
  827
  828run_test_once(Unit, Name, Line, Options, Body) :-
  829    current_test_flag(test_options, GlobalOptions),
  830    option(sto(false), GlobalOptions, false),
  831    !,
  832    current_unification_capability(Type),
  833    begin_test(Unit, Name, Line, Type),
  834    run_test_6(Unit, Name, Line, Options, Body, Result),
  835    end_test(Unit, Name, Line, Type),
  836    report_result(Result, Options).
  837run_test_once(Unit, Name, Line, Options, Body) :-
  838    current_unit(Unit, _Module, _Supers, UnitOptions),
  839    option(sto(Type), UnitOptions),
  840    \+ option(sto(_), Options),
  841    !,
  842    current_unification_capability(Cap0),
  843    call_cleanup(run_test_cap(Unit, Name, Line, [sto(Type)|Options], Body),
  844                 set_unification_capability(Cap0)).
  845run_test_once(Unit, Name, Line, Options, Body) :-
  846    current_unification_capability(Cap0),
  847    call_cleanup(run_test_cap(Unit, Name, Line, Options, Body),
  848                 set_unification_capability(Cap0)).
  849
  850run_test_cap(Unit, Name, Line, Options, Body) :-
  851    (   option(sto(Type), Options)
  852    ->  unification_capability(Type),
  853        set_unification_capability(Type),
  854        begin_test(Unit, Name, Line, Type),
  855        run_test_6(Unit, Name, Line, Options, Body, Result),
  856        end_test(Unit, Name, Line, Type),
  857        report_result(Result, Options)
  858    ;   findall(Key-(Type+Result),
  859                test_caps(Type, Unit, Name, Line, Options, Body, Result, Key),
  860                Pairs),
  861        group_pairs_by_key(Pairs, Keyed),
  862        (   Keyed == []
  863        ->  true
  864        ;   Keyed = [_-Results]
  865        ->  Results = [_Type+Result|_],
  866            report_result(Result, Options)          % consistent results
  867        ;   pairs_values(Pairs, ResultByType),
  868            report_result(sto(Unit, Name, Line, ResultByType), Options)
  869        )
  870    ).

 test_caps(-Type, +Unit, +Name, +Line, +Options, +Body, -Result, -Key) is nondet

  874test_caps(Type, Unit, Name, Line, Options, Body, Result, Key) :-
  875    unification_capability(Type),
  876    set_unification_capability(Type),
  877    begin_test(Unit, Name, Line, Type),
  878    run_test_6(Unit, Name, Line, Options, Body, Result),
  879    end_test(Unit, Name, Line, Type),
  880    result_to_key(Result, Key),
  881    Key \== setup_failed.
  882
  883result_to_key(blocked(_, _, _, _), blocked).
  884result_to_key(failure(_, _, _, How0), failure(How1)) :-
  885    ( How0 = succeeded(_T) -> How1 = succeeded ; How0 = How1 ).
  886result_to_key(success(_, _, _, Determinism, _), success(Determinism)).
  887result_to_key(setup_failed(_,_,_), setup_failed).
  888
  889report_result(blocked(Unit, Name, Line, Reason), _) :-
  890    !,
  891    assert(blocked(Unit, Name, Line, Reason)).
  892report_result(failure(Unit, Name, Line, How), Options) :-
  893    !,
  894    failure(Unit, Name, Line, How, Options).
  895report_result(success(Unit, Name, Line, Determinism, Time), Options) :-
  896    !,
  897    success(Unit, Name, Line, Determinism, Time, Options).
  898report_result(setup_failed(_Unit, _Name, _Line), _Options).
  899report_result(sto(Unit, Name, Line, ResultByType), Options) :-
  900    assert(sto(Unit, Name, Line, ResultByType)),
  901    print_message(error, plunit(sto(Unit, Name, Line))),
  902    report_sto_results(ResultByType, Options).
  903
  904report_sto_results([], _).
  905report_sto_results([Type+Result|T], Options) :-
  906    print_message(error, plunit(sto(Type, Result))),
  907    report_sto_results(T, Options).

 run_test_6(+Unit, +Name, +Line, +Options, :Body, -Result) is det

Result is one of:

• blocked(Unit, Name, Line, Reason)
• failure(Unit, Name, Line, How)
• success(Unit, Name, Line, Determinism, Time)
• setup_failed(Unit, Name, Line)

  919run_test_6(Unit, Name, Line, Options, _Body,
  920           blocked(Unit, Name, Line, Reason)) :-
  921    option(blocked(Reason), Options),
  922    !.
  923run_test_6(Unit, Name, Line, Options, Body, Result) :-
  924    option(all(Answer), Options),                  % all(Bindings)
  925    !,
  926    nondet_test(all(Answer), Unit, Name, Line, Options, Body, Result).
  927run_test_6(Unit, Name, Line, Options, Body, Result) :-
  928    option(set(Answer), Options),                  % set(Bindings)
  929    !,
  930    nondet_test(set(Answer), Unit, Name, Line, Options, Body, Result).
  931run_test_6(Unit, Name, Line, Options, Body, Result) :-
  932    option(fail, Options),                         % fail
  933    !,
  934    unit_module(Unit, Module),
  935    (   setup(Module, test(Unit,Name,Line), Options)
  936    ->  statistics(runtime, [T0,_]),
  937        (   catch(Module:Body, E, true)
  938        ->  (   var(E)
  939            ->  statistics(runtime, [T1,_]),
  940                Time is (T1 - T0)/1000.0,
  941                Result = failure(Unit, Name, Line, succeeded(Time)),
  942                cleanup(Module, Options)
  943            ;   Result = failure(Unit, Name, Line, E),
  944                cleanup(Module, Options)
  945            )
  946        ;   statistics(runtime, [T1,_]),
  947            Time is (T1 - T0)/1000.0,
  948            Result = success(Unit, Name, Line, true, Time),
  949            cleanup(Module, Options)
  950        )
  951    ;   Result = setup_failed(Unit, Name, Line)
  952    ).
  953run_test_6(Unit, Name, Line, Options, Body, Result) :-
  954    option(true(Cmp), Options),
  955    !,
  956    unit_module(Unit, Module),
  957    (   setup(Module, test(Unit,Name,Line), Options) % true(Binding)
  958    ->  statistics(runtime, [T0,_]),
  959        (   catch(call_det(Module:Body, Det), E, true)
  960        ->  (   var(E)
  961            ->  statistics(runtime, [T1,_]),
  962                Time is (T1 - T0)/1000.0,
  963                (   catch(Module:Cmp, E, true)
  964                ->  (   var(E)
  965                    ->  Result = success(Unit, Name, Line, Det, Time)
  966                    ;   Result = failure(Unit, Name, Line, cmp_error(Cmp, E))
  967                    )
  968                ;   Result = failure(Unit, Name, Line, wrong_answer(Cmp))
  969                ),
  970                cleanup(Module, Options)
  971            ;   Result = failure(Unit, Name, Line, E),
  972                cleanup(Module, Options)
  973            )
  974        ;   Result = failure(Unit, Name, Line, failed),
  975            cleanup(Module, Options)
  976        )
  977    ;   Result = setup_failed(Unit, Name, Line)
  978    ).
  979run_test_6(Unit, Name, Line, Options, Body, Result) :-
  980    option(throws(Expect), Options),
  981    !,
  982    unit_module(Unit, Module),
  983    (   setup(Module, test(Unit,Name,Line), Options)
  984    ->  statistics(runtime, [T0,_]),
  985        (   catch(Module:Body, E, true)
  986        ->  (   var(E)
  987            ->  Result = failure(Unit, Name, Line, no_exception),
  988                cleanup(Module, Options)
  989            ;   statistics(runtime, [T1,_]),
  990                Time is (T1 - T0)/1000.0,
  991                (   match_error(Expect, E)
  992                ->  Result = success(Unit, Name, Line, true, Time)
  993                ;   Result = failure(Unit, Name, Line, wrong_error(Expect, E))
  994                ),
  995                cleanup(Module, Options)
  996            )
  997        ;   Result = failure(Unit, Name, Line, failed),
  998            cleanup(Module, Options)
  999        )
 1000    ;   Result = setup_failed(Unit, Name, Line)
 1001    ).

 non_det_test(+Expected, +Unit, +Name, +Line, +Options, +Body, -Result)

Run tests on non-deterministic predicates.

 1008nondet_test(Expected, Unit, Name, Line, Options, Body, Result) :-
 1009    unit_module(Unit, Module),
 1010    result_vars(Expected, Vars),
 1011    statistics(runtime, [T0,_]),
 1012    (   setup(Module, test(Unit,Name,Line), Options)
 1013    ->  (   catch(findall(Vars, Module:Body, Bindings), E, true)
 1014        ->  (   var(E)
 1015            ->  statistics(runtime, [T1,_]),
 1016                Time is (T1 - T0)/1000.0,
 1017                (   nondet_compare(Expected, Bindings, Unit, Name, Line)
 1018                ->  Result = success(Unit, Name, Line, true, Time)
 1019                ;   Result = failure(Unit, Name, Line, wrong_answer(Expected, Bindings))
 1020                ),
 1021                cleanup(Module, Options)
 1022            ;   Result = failure(Unit, Name, Line, E),
 1023                cleanup(Module, Options)
 1024            )
 1025        )
 1026    ;   Result = setup_failed(Unit, Name, Line)
 1027    ).

 result_vars(+Expected, -Vars) is det

Create a term v(V1, ...) containing all variables at the left side of the comparison operator on Expected.

 1035result_vars(Expected, Vars) :-
 1036    arg(1, Expected, CmpOp),
 1037    arg(1, CmpOp, Vars).

 nondet_compare(+Expected, +Bindings, +Unit, +Name, +Line) is semidet

Compare list/set results for non-deterministic predicates.

bug

- Sort should deal with equivalence on the comparison operator.

To be done

- Properly report errors

 1047nondet_compare(all(Cmp), Bindings, _Unit, _Name, _Line) :-
 1048    cmp(Cmp, _Vars, Op, Values),
 1049    cmp_list(Values, Bindings, Op).
 1050nondet_compare(set(Cmp), Bindings0, _Unit, _Name, _Line) :-
 1051    cmp(Cmp, _Vars, Op, Values0),
 1052    sort(Bindings0, Bindings),
 1053    sort(Values0, Values),
 1054    cmp_list(Values, Bindings, Op).
 1055
 1056cmp_list([], [], _Op).
 1057cmp_list([E0|ET], [V0|VT], Op) :-
 1058    call(Op, E0, V0),
 1059    cmp_list(ET, VT, Op).

 cmp(+CmpTerm, -Left, -Op, -Right) is det

 1063cmp(Var  == Value, Var,  ==, Value).
 1064cmp(Var =:= Value, Var, =:=, Value).
 1065cmp(Var  =  Value, Var,  =,  Value).
 1066:- if(swi). 1067cmp(Var =@= Value, Var, =@=, Value).
 1068:- else. 1069:- if(sicstus). 1070cmp(Var =@= Value, Var, variant, Value). % variant/2 is the same =@=
 1071:- endif. 1072:- endif.

 call_det(:Goal, -Det) is nondet

True if Goal succeeded. Det is unified to true if Goal left no choicepoints and false otherwise.

 1080:- if((swi|sicstus)). 1081call_det(Goal, Det) :-
 1082    call_cleanup(Goal,Det0=true),
 1083    ( var(Det0) -> Det = false ; Det = true ).
 1084:- else. 1085call_det(Goal, true) :-
 1086    call(Goal).
 1087:- endif.

 match_error(+Expected, +Received) is semidet

True if the Received errors matches the expected error. Matching is based on subsumes_term/2.

 1094match_error(Expect, Rec) :-
 1095    subsumes_term(Expect, Rec).

 setup(+Module, +Context, +Options) is semidet

Call the setup handler and fail if it cannot run for some reason. The condition handler is similar, but failing is not considered an error. Context is one of

unit(Unit)

If it is the setup handler for a unit

test(Unit, Name, Line)

If it is the setup handler for a test

 1108setup(Module, Context, Options) :-
 1109    option(condition(Condition), Options),
 1110    option(setup(Setup), Options),
 1111    !,
 1112    setup(Module, Context, [condition(Condition)]),
 1113    setup(Module, Context, [setup(Setup)]).
 1114setup(Module, Context, Options) :-
 1115    option(setup(Setup), Options),
 1116    !,
 1117    (   catch(call_ex(Module, Setup), E, true)
 1118    ->  (   var(E)
 1119        ->  true
 1120        ;   print_message(error, plunit(error(setup, Context, E))),
 1121            fail
 1122        )
 1123    ;   print_message(error, error(goal_failed(Setup), _)),
 1124        fail
 1125    ).
 1126setup(Module, Context, Options) :-
 1127    option(condition(Setup), Options),
 1128    !,
 1129    (   catch(call_ex(Module, Setup), E, true)
 1130    ->  (   var(E)
 1131        ->  true
 1132        ;   print_message(error, plunit(error(condition, Context, E))),
 1133            fail
 1134        )
 1135    ;   fail
 1136    ).
 1137setup(_,_,_).

 call_ex(+Module, +Goal)

Call Goal in Module after applying goal expansion.

 1143call_ex(Module, Goal) :-
 1144    Module:(expand_goal(Goal, GoalEx),
 1145                GoalEx).

 cleanup(+Module, +Options) is det

Call the cleanup handler and succeed. Failure or error of the cleanup handler is reported, but tests continue normally.

 1152cleanup(Module, Options) :-
 1153    option(cleanup(Cleanup), Options, true),
 1154    (   catch(call_ex(Module, Cleanup), E, true)
 1155    ->  (   var(E)
 1156        ->  true
 1157        ;   print_message(warning, E)
 1158        )
 1159    ;   print_message(warning, goal_failed(Cleanup, '(cleanup handler)'))
 1160    ).
 1161
 1162success(Unit, Name, Line, Det, _Time, Options) :-
 1163    memberchk(fixme(Reason), Options),
 1164    !,
 1165    (   (   Det == true
 1166        ;   memberchk(nondet, Options)
 1167        )
 1168    ->  put_char(user_error, +),
 1169        Ok = passed
 1170    ;   put_char(user_error, !),
 1171        Ok = nondet
 1172    ),
 1173    flush_output(user_error),
 1174    assert(fixme(Unit, Name, Line, Reason, Ok)).
 1175success(Unit, Name, Line, _, _, Options) :-
 1176    failed_assertion(Unit, Name, Line, _,_,_,_),
 1177    !,
 1178    failure(Unit, Name, Line, assertion, Options).
 1179success(Unit, Name, Line, Det, Time, Options) :-
 1180    assert(passed(Unit, Name, Line, Det, Time)),
 1181    (   (   Det == true
 1182        ;   memberchk(nondet, Options)
 1183        )
 1184    ->  put_char(user_error, .)
 1185    ;   unit_file(Unit, File),
 1186        print_message(warning, plunit(nondet(File, Line, Name)))
 1187    ),
 1188    flush_output(user_error).
 1189
 1190failure(Unit, Name, Line, _, Options) :-
 1191    memberchk(fixme(Reason), Options),
 1192    !,
 1193    put_char(user_error, -),
 1194    flush_output(user_error),
 1195    assert(fixme(Unit, Name, Line, Reason, failed)).
 1196failure(Unit, Name, Line, E, Options) :-
 1197    report_failure(Unit, Name, Line, E, Options),
 1198    assert_cyclic(failed(Unit, Name, Line, E)).

 assert_cyclic(+Term) is det

Assert a possibly cyclic unit clause. Current SWI-Prolog assert/1 does not handle cyclic terms, so we emulate this using the recorded database.

To be done

- Implement cycle-safe assert and remove this.

 1208:- if(swi). 1209assert_cyclic(Term) :-
 1210    acyclic_term(Term),
 1211    !,
 1212    assert(Term).
 1213assert_cyclic(Term) :-
 1214    Term =.. [Functor|Args],
 1215    recorda(cyclic, Args, Id),
 1216    functor(Term, _, Arity),
 1217    length(NewArgs, Arity),
 1218    Head =.. [Functor|NewArgs],
 1219    assert((Head :- recorded(_, Var, Id), Var = NewArgs)).
 1220:- else. 1221:- if(sicstus). 1222:- endif. 1223assert_cyclic(Term) :-
 1224    assert(Term).
 1225:- endif. 1226
 1227
 1228                 /*******************************
 1229                 *            REPORTING         *
 1230                 *******************************/

 begin_test(Unit, Test, Line, STO) is det

 end_test(Unit, Test, Line, STO) is det

Maintain running/5 and report a test has started/is ended using a silent message:

• plunit(begin(Unit:Test, File:Line, STO))
• plunit(end(Unit:Test, File:Line, STO))

See also

- message_hook/3 for intercepting these messages

 1243begin_test(Unit, Test, Line, STO) :-
 1244    thread_self(Me),
 1245    assert(running(Unit, Test, Line, STO, Me)),
 1246    unit_file(Unit, File),
 1247    print_message(silent, plunit(begin(Unit:Test, File:Line, STO))).
 1248
 1249end_test(Unit, Test, Line, STO) :-
 1250    thread_self(Me),
 1251    retractall(running(_,_,_,_,Me)),
 1252    unit_file(Unit, File),
 1253    print_message(silent, plunit(end(Unit:Test, File:Line, STO))).

 running_tests is det

Print the currently running test.

 1259running_tests :-
 1260    running_tests(Running),
 1261    print_message(informational, plunit(running(Running))).
 1262
 1263running_tests(Running) :-
 1264    findall(running(Unit:Test, File:Line, STO, Thread),
 1265            (   running(Unit, Test, Line, STO, Thread),
 1266                unit_file(Unit, File)
 1267            ), Running).

 current_test(?Unit, ?Test, ?Line, ?Body, ?Options)

True when a test with the specified properties is loaded.

 1274current_test(Unit, Test, Line, Body, Options) :-
 1275    current_unit(Unit, Module, _Supers, _UnitOptions),
 1276    Module:'unit test'(Test, Line, Options, Body).

 check_for_test_errors is semidet

True if there are no errors, otherwise false.

 1282check_for_test_errors :-
 1283    number_of_clauses(failed/4, Failed),
 1284    number_of_clauses(failed_assertion/7, FailedAssertion),
 1285    number_of_clauses(sto/4, STO),
 1286    Failed+FailedAssertion+STO =:= 0.     % fail on errors

 report is det

Print a summary of the tests that ran.

 1293report :-
 1294    number_of_clauses(passed/5, Passed),
 1295    number_of_clauses(failed/4, Failed),
 1296    number_of_clauses(failed_assertion/7, FailedAssertion),
 1297    number_of_clauses(blocked/4, Blocked),
 1298    number_of_clauses(sto/4, STO),
 1299    (   Passed+Failed+FailedAssertion+Blocked+STO =:= 0
 1300    ->  info(plunit(no_tests))
 1301    ;   Failed+FailedAssertion+Blocked+STO =:= 0
 1302    ->  report_fixme,
 1303        info(plunit(all_passed(Passed)))
 1304    ;   report_blocked,
 1305        report_fixme,
 1306        report_failed_assertions,
 1307        report_failed,
 1308        report_sto,
 1309        info(plunit(passed(Passed)))
 1310    ).
 1311
 1312number_of_clauses(F/A,N) :-
 1313    (   current_predicate(F/A)
 1314    ->  functor(G,F,A),
 1315        findall(t, G, Ts),
 1316        length(Ts, N)
 1317    ;   N = 0
 1318    ).
 1319
 1320report_blocked :-
 1321    number_of_clauses(blocked/4,N),
 1322    N > 0,
 1323    !,
 1324    info(plunit(blocked(N))),
 1325    (   blocked(Unit, Name, Line, Reason),
 1326        unit_file(Unit, File),
 1327        print_message(informational,
 1328                      plunit(blocked(File:Line, Name, Reason))),
 1329        fail ; true
 1330    ).
 1331report_blocked.
 1332
 1333report_failed :-
 1334    number_of_clauses(failed/4, N),
 1335    info(plunit(failed(N))).
 1336
 1337report_failed_assertions :-
 1338    number_of_clauses(failed_assertion/7, N),
 1339    info(plunit(failed_assertions(N))).
 1340
 1341report_sto :-
 1342    number_of_clauses(sto/4, N),
 1343    info(plunit(sto(N))).
 1344
 1345report_fixme :-
 1346    report_fixme(_,_,_).
 1347
 1348report_fixme(TuplesF, TuplesP, TuplesN) :-
 1349    fixme(failed, TuplesF, Failed),
 1350    fixme(passed, TuplesP, Passed),
 1351    fixme(nondet, TuplesN, Nondet),
 1352    print_message(informational, plunit(fixme(Failed, Passed, Nondet))).
 1353
 1354
 1355fixme(How, Tuples, Count) :-
 1356    findall(fixme(Unit, Name, Line, Reason, How),
 1357            fixme(Unit, Name, Line, Reason, How), Tuples),
 1358    length(Tuples, Count).
 1359
 1360
 1361report_failure(_, _, _, assertion, _) :-
 1362    !,
 1363    put_char(user_error, 'A').
 1364report_failure(Unit, Name, Line, Error, _Options) :-
 1365    print_message(error, plunit(failed(Unit, Name, Line, Error))).

 test_report(What) is det

Produce reports on test results after the run.

 1372test_report(fixme) :-
 1373    !,
 1374    report_fixme(TuplesF, TuplesP, TuplesN),
 1375    append([TuplesF, TuplesP, TuplesN], Tuples),
 1376    print_message(informational, plunit(fixme(Tuples))).
 1377test_report(What) :-
 1378    throw_error(domain_error(report_class, What), _).
 1379
 1380
 1381                 /*******************************
 1382                 *             INFO             *
 1383                 *******************************/

 current_test_set(?Unit) is nondet

True if Unit is a currently loaded test-set.

 1389current_test_set(Unit) :-
 1390    current_unit(Unit, _Module, _Context, _Options).

 unit_file(+Unit, -File) is det

unit_file(-Unit, +File) is nondet

 1395unit_file(Unit, File) :-
 1396    current_unit(Unit, Module, _Context, _Options),
 1397    current_module(Module, File).
 1398unit_file(Unit, PlFile) :-
 1399    nonvar(PlFile),
 1400    test_file_for(TestFile, PlFile),
 1401    current_module(Module, TestFile),
 1402    current_unit(Unit, Module, _Context, _Options).
 1403
 1404
 1405                 /*******************************
 1406                 *             FILES            *
 1407                 *******************************/

 load_test_files(+Options) is det

Load .plt test-files related to loaded source-files.

 1413load_test_files(_Options) :-
 1414    (   source_file(File),
 1415        file_name_extension(Base, Old, File),
 1416        Old \== plt,
 1417        file_name_extension(Base, plt, TestFile),
 1418        exists_file(TestFile),
 1419        (   test_file_for(TestFile, File)
 1420        ->  true
 1421        ;   load_files(TestFile,
 1422                       [ if(changed),
 1423                         imports([])
 1424                       ]),
 1425            asserta(test_file_for(TestFile, File))
 1426        ),
 1427        fail ; true
 1428    ).
 1429
 1430
 1431
 1432                 /*******************************
 1433                 *           MESSAGES           *
 1434                 *******************************/

 info(+Term)

Runs print_message(Level, Term), where Level is one of silent or informational (default).

 1441info(Term) :-
 1442    message_level(Level),
 1443    print_message(Level, Term).
 1444
 1445message_level(Level) :-
 1446    current_test_flag(test_options, Options),
 1447    option(silent(Silent), Options, false),
 1448    (   Silent == false
 1449    ->  Level = informational
 1450    ;   Level = silent
 1451    ).
 1452
 1453locationprefix(File:Line) -->
 1454    !,
 1455    [ '~w:~d:\n\t'-[File,Line]].
 1456locationprefix(test(Unit,_Test,Line)) -->
 1457    !,
 1458    { unit_file(Unit, File) },
 1459    locationprefix(File:Line).
 1460locationprefix(unit(Unit)) -->
 1461    !,
 1462    [ 'PL-Unit: unit ~w: '-[Unit] ].
 1463locationprefix(FileLine) -->
 1464    { throw_error(type_error(locationprefix,FileLine), _) }.
 1465
 1466:- discontiguous
 1467    message//1. 1468
 1469message(error(context_error(plunit_close(Name, -)), _)) -->
 1470    [ 'PL-Unit: cannot close unit ~w: no open unit'-[Name] ].
 1471message(error(context_error(plunit_close(Name, Start)), _)) -->
 1472    [ 'PL-Unit: cannot close unit ~w: current unit is ~w'-[Name, Start] ].
 1473message(plunit(nondet(File, Line, Name))) -->
 1474    locationprefix(File:Line),
 1475    [ 'PL-Unit: Test ~w: Test succeeded with choicepoint'- [Name] ].
 1476message(error(plunit(incompatible_options, Tests), _)) -->
 1477    [ 'PL-Unit: incompatible test-options: ~p'-[Tests] ].
 1478
 1479                                        % Unit start/end
 1480:- if(swi). 1481message(plunit(begin(Unit))) -->
 1482    [ 'PL-Unit: ~w '-[Unit], flush ].
 1483message(plunit(end(_Unit))) -->
 1484    [ at_same_line, ' done' ].
 1485:- else. 1486message(plunit(begin(Unit))) -->
 1487    [ 'PL-Unit: ~w '-[Unit]/*, flush-[]*/ ].
 1488message(plunit(end(_Unit))) -->
 1489    [ ' done'-[] ].
 1490:- endif. 1491message(plunit(blocked(unit(Unit, Reason)))) -->
 1492    [ 'PL-Unit: ~w blocked: ~w'-[Unit, Reason] ].
 1493message(plunit(running([]))) -->
 1494    !,
 1495    [ 'PL-Unit: no tests running' ].
 1496message(plunit(running([One]))) -->
 1497    !,
 1498    [ 'PL-Unit: running ' ],
 1499    running(One).
 1500message(plunit(running(More))) -->
 1501    !,
 1502    [ 'PL-Unit: running tests:', nl ],
 1503    running(More).
 1504message(plunit(fixme([]))) --> !.
 1505message(plunit(fixme(Tuples))) -->
 1506    !,
 1507    fixme_message(Tuples).
 1508
 1509                                        % Blocked tests
 1510message(plunit(blocked(1))) -->
 1511    !,
 1512    [ 'one test is blocked:'-[] ].
 1513message(plunit(blocked(N))) -->
 1514    [ '~D tests are blocked:'-[N] ].
 1515message(plunit(blocked(Pos, Name, Reason))) -->
 1516    locationprefix(Pos),
 1517    test_name(Name),
 1518    [ ': ~w'-[Reason] ].
 1519
 1520                                        % fail/success
 1521message(plunit(no_tests)) -->
 1522    !,
 1523    [ 'No tests to run' ].
 1524message(plunit(all_passed(1))) -->
 1525    !,
 1526    [ 'test passed' ].
 1527message(plunit(all_passed(Count))) -->
 1528    !,
 1529    [ 'All ~D tests passed'-[Count] ].
 1530message(plunit(passed(Count))) -->
 1531    !,
 1532    [ '~D tests passed'-[Count] ].
 1533message(plunit(failed(0))) -->
 1534    !,
 1535    [].
 1536message(plunit(failed(1))) -->
 1537    !,
 1538    [ '1 test failed'-[] ].
 1539message(plunit(failed(N))) -->
 1540    [ '~D tests failed'-[N] ].
 1541message(plunit(failed_assertions(0))) -->
 1542    !,
 1543    [].
 1544message(plunit(failed_assertions(1))) -->
 1545    !,
 1546    [ '1 assertion failed'-[] ].
 1547message(plunit(failed_assertions(N))) -->
 1548    [ '~D assertions failed'-[N] ].
 1549message(plunit(sto(0))) -->
 1550    !,
 1551    [].
 1552message(plunit(sto(N))) -->
 1553    [ '~D test results depend on unification mode'-[N] ].
 1554message(plunit(fixme(0,0,0))) -->
 1555    [].
 1556message(plunit(fixme(Failed,0,0))) -->
 1557    !,
 1558    [ 'all ~D tests flagged FIXME failed'-[Failed] ].
 1559message(plunit(fixme(Failed,Passed,0))) -->
 1560    [ 'FIXME: ~D failed; ~D passed'-[Failed, Passed] ].
 1561message(plunit(fixme(Failed,Passed,Nondet))) -->
 1562    { TotalPassed is Passed+Nondet },
 1563    [ 'FIXME: ~D failed; ~D passed; (~D nondet)'-
 1564      [Failed, TotalPassed, Nondet] ].
 1565message(plunit(failed(Unit, Name, Line, Failure))) -->
 1566    { unit_file(Unit, File) },
 1567    locationprefix(File:Line),
 1568    test_name(Name),
 1569    [': '-[] ],
 1570    failure(Failure).
 1571:- if(swi). 1572message(plunit(failed_assertion(Unit, Name, Line, AssertLoc,
 1573                                _STO, Reason, Goal))) -->
 1574    { unit_file(Unit, File) },
 1575    locationprefix(File:Line),
 1576    test_name(Name),
 1577    [ ': assertion'-[] ],
 1578    assertion_location(AssertLoc, File),
 1579    assertion_reason(Reason), ['\n\t'],
 1580    assertion_goal(Unit, Goal).
 1581
 1582assertion_location(File:Line, File) -->
 1583    [ ' at line ~w'-[Line] ].
 1584assertion_location(File:Line, _) -->
 1585    [ ' at ~w:~w'-[File, Line] ].
 1586assertion_location(unknown, _) -->
 1587    [].
 1588
 1589assertion_reason(fail) -->
 1590    !,
 1591    [ ' failed'-[] ].
 1592assertion_reason(Error) -->
 1593    { message_to_string(Error, String) },
 1594    [ ' raised "~w"'-[String] ].
 1595
 1596assertion_goal(Unit, Goal) -->
 1597    { unit_module(Unit, Module),
 1598      unqualify(Goal, Module, Plain)
 1599    },
 1600    [ 'Assertion: ~p'-[Plain] ].
 1601
 1602unqualify(Var, _, Var) :-
 1603    var(Var),
 1604    !.
 1605unqualify(M:Goal, Unit, Goal) :-
 1606    nonvar(M),
 1607    unit_module(Unit, M),
 1608    !.
 1609unqualify(M:Goal, _, Goal) :-
 1610    callable(Goal),
 1611    predicate_property(M:Goal, imported_from(system)),
 1612    !.
 1613unqualify(Goal, _, Goal).
 1614
 1615:- endif. 1616                                        % Setup/condition errors
 1617message(plunit(error(Where, Context, Exception))) -->
 1618    locationprefix(Context),
 1619    { message_to_string(Exception, String) },
 1620    [ 'error in ~w: ~w'-[Where, String] ].
 1621
 1622                                        % STO messages
 1623message(plunit(sto(Unit, Name, Line))) -->
 1624    { unit_file(Unit, File) },
 1625       locationprefix(File:Line),
 1626       test_name(Name),
 1627       [' is subject to occurs check (STO): '-[] ].
 1628message(plunit(sto(Type, Result))) -->
 1629    sto_type(Type),
 1630    sto_result(Result).
 1631
 1632                                        % Interrupts (SWI)
 1633:- if(swi). 1634message(interrupt(begin)) -->
 1635    { thread_self(Me),
 1636      running(Unit, Test, Line, STO, Me),
 1637      !,
 1638      unit_file(Unit, File)
 1639    },
 1640    [ 'Interrupted test '-[] ],
 1641    running(running(Unit:Test, File:Line, STO, Me)),
 1642    [nl],
 1643    '$messages':prolog_message(interrupt(begin)).
 1644message(interrupt(begin)) -->
 1645    '$messages':prolog_message(interrupt(begin)).
 1646:- endif. 1647
 1648test_name(@(Name,Bindings)) -->
 1649    !,
 1650    [ 'test ~w (forall bindings = ~p)'-[Name, Bindings] ].
 1651test_name(Name) -->
 1652    !,
 1653    [ 'test ~w'-[Name] ].
 1654
 1655sto_type(sto_error_incomplete) -->
 1656    [ 'Finite trees (error checking): ' ].
 1657sto_type(rational_trees) -->
 1658    [ 'Rational trees: ' ].
 1659sto_type(finite_trees) -->
 1660    [ 'Finite trees: ' ].
 1661
 1662sto_result(success(_Unit, _Name, _Line, Det, Time)) -->
 1663    det(Det),
 1664    [ ' success in ~2f seconds'-[Time] ].
 1665sto_result(failure(_Unit, _Name, _Line, How)) -->
 1666    failure(How).
 1667
 1668det(true) -->
 1669    [ 'deterministic' ].
 1670det(false) -->
 1671    [ 'non-deterministic' ].
 1672
 1673running(running(Unit:Test, File:Line, STO, Thread)) -->
 1674    thread(Thread),
 1675    [ '~q:~q at ~w:~d'-[Unit, Test, File, Line] ],
 1676    current_sto(STO).
 1677running([H|T]) -->
 1678    ['\t'], running(H),
 1679    (   {T == []}
 1680    ->  []
 1681    ;   [nl], running(T)
 1682    ).
 1683
 1684thread(main) --> !.
 1685thread(Other) -->
 1686    [' [~w] '-[Other] ].
 1687
 1688current_sto(sto_error_incomplete) -->
 1689    [ ' (STO: error checking)' ].
 1690current_sto(rational_trees) -->
 1691    [].
 1692current_sto(finite_trees) -->
 1693    [ ' (STO: occurs check enabled)' ].
 1694
 1695:- if(swi). 1696write_term(T, OPS) -->
 1697    ['~@'-[write_term(T,OPS)]].
 1698:- else. 1699write_term(T, _OPS) -->
 1700    ['~q'-[T]].
 1701:- endif. 1702
 1703expected_got_ops_(Ex, E, OPS, Goals) -->
 1704    ['    Expected: '-[]], write_term(Ex, OPS), [nl],
 1705    ['    Got:      '-[]], write_term(E,  OPS), [nl],
 1706    ( { Goals = [] } -> []
 1707    ; ['       with: '-[]], write_term(Goals, OPS), [nl]
 1708    ).
 1709
 1710
 1711failure(Var) -->
 1712    { var(Var) },
 1713    !,
 1714    [ 'Unknown failure?' ].
 1715failure(succeeded(Time)) -->
 1716    !,
 1717    [ 'must fail but succeeded in ~2f seconds~n'-[Time] ].
 1718failure(wrong_error(Expected, Error)) -->
 1719    !,
 1720    { copy_term(Expected-Error, Ex-E, Goals),
 1721      numbervars(Ex-E-Goals, 0, _),
 1722      write_options(OPS)
 1723    },
 1724    [ 'wrong error'-[], nl ],
 1725    expected_got_ops_(Ex, E, OPS, Goals).
 1726failure(wrong_answer(Cmp)) -->
 1727    { Cmp =.. [Op,Answer,Expected],
 1728      !,
 1729      copy_term(Expected-Answer, Ex-A, Goals),
 1730      numbervars(Ex-A-Goals, 0, _),
 1731      write_options(OPS)
 1732    },
 1733    [ 'wrong answer (compared using ~w)'-[Op], nl ],
 1734    expected_got_ops_(Ex, A, OPS, Goals).
 1735failure(wrong_answer(CmpExpected, Bindings)) -->
 1736    { (   CmpExpected = all(Cmp)
 1737      ->  Cmp =.. [_Op1,_,Expected],
 1738          Got = Bindings,
 1739          Type = all
 1740      ;   CmpExpected = set(Cmp),
 1741          Cmp =.. [_Op2,_,Expected0],
 1742          sort(Expected0, Expected),
 1743          sort(Bindings, Got),
 1744          Type = set
 1745      )
 1746    },
 1747    [ 'wrong "~w" answer:'-[Type] ],
 1748    [ nl, '    Expected: ~q'-[Expected] ],
 1749    [ nl, '       Found: ~q'-[Got] ].
 1750:- if(swi). 1751failure(cmp_error(_Cmp, Error)) -->
 1752    { message_to_string(Error, Message) },
 1753    [ 'Comparison error: ~w'-[Message] ].
 1754failure(Error) -->
 1755    { Error = error(_,_),
 1756      !,
 1757      message_to_string(Error, Message)
 1758    },
 1759    [ 'received error: ~w'-[Message] ].
 1760:- endif. 1761failure(Why) -->
 1762    [ '~p~n'-[Why] ].
 1763
 1764fixme_message([]) --> [].
 1765fixme_message([fixme(Unit, _Name, Line, Reason, How)|T]) -->
 1766    { unit_file(Unit, File) },
 1767    fixme_message(File:Line, Reason, How),
 1768    (   {T == []}
 1769    ->  []
 1770    ;   [nl],
 1771        fixme_message(T)
 1772    ).
 1773
 1774fixme_message(Location, Reason, failed) -->
 1775    [ 'FIXME: ~w: ~w'-[Location, Reason] ].
 1776fixme_message(Location, Reason, passed) -->
 1777    [ 'FIXME: ~w: passed ~w'-[Location, Reason] ].
 1778fixme_message(Location, Reason, nondet) -->
 1779    [ 'FIXME: ~w: passed (nondet) ~w'-[Location, Reason] ].
 1780
 1781
 1782write_options([ numbervars(true),
 1783                quoted(true),
 1784                portray(true),
 1785                max_depth(100),
 1786                attributes(portray)
 1787              ]).
 1788
 1789:- if(swi). 1790
 1791:- multifile
 1792    prolog:message/3,
 1793    user:message_hook/3. 1794
 1795prolog:message(Term) -->
 1796    message(Term).
 1797
 1798%       user:message_hook(+Term, +Kind, +Lines)
 1799
 1800user:message_hook(make(done(Files)), _, _) :-
 1801    make_run_tests(Files),
 1802    fail.                           % give other hooks a chance
 1803
 1804:- endif. 1805
 1806:- if(sicstus). 1807
 1808user:generate_message_hook(Message) -->
 1809    message(Message),
 1810    [nl].                           % SICStus requires nl at the end