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

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

 current_test_flag(?Name, ?Value) is nondet

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

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

 set_test_flag(+Name, +Value) is det

  171set_test_flag(Name, Val) :-
  172    var(Name),
  173    !,
  174    throw_error(instantiation_error, set_test_flag(Name,Val)).
  175set_test_flag( Name, Val ) :-
  176    retractall(test_flag(Name,_)),
  177    asserta(test_flag(Name, Val)).
  178
  179:- op(1150, fx, thread_local).  180
  181user:term_expansion((:- thread_local(PI)), (:- dynamic(PI))) :-
  182    prolog_load_context(module, plunit).
  183
  184:- endif.  185
  186                 /*******************************
  187                 *            IMPORTS           *
  188                 *******************************/
  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   ).

 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.

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

 loading_tests

True if tests must be loaded.

  255loading_tests :-
  256    current_test_flag(test_options, Options),
  257    option(load(Load), Options, normal),
  258    (   Load == always
  259    ->  true
  260    ;   Load == normal,
  261        \+ current_test_flag(optimise, true)
  262    ).
  263
  264                 /*******************************
  265                 *            MODULE            *
  266                 *******************************/
  267
  268:- dynamic
  269    loading_unit/4,                 % Unit, Module, File, OldSource
  270    current_unit/4,                 % Unit, Module, Context, Options
  271    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).

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

 end_tests(+Name) is det

Close a unit-test module.

To be done

- Run tests/clean module?

- End of file?

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

 make_unit_module(+Name, -ModuleName) is det

 unit_module(+Name, -ModuleName) is det

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

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

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

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

 expand(+Term, -Clauses) is semidet

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

  517valid_options(Options, Pred) :-
  518    must_be(list, Options),
  519    verify_options(Options, Pred).
  520
  521verify_options([], _).
  522verify_options([H|T], Pred) :-
  523    (   call(Pred, H)
  524    ->  verify_options(T, Pred)
  525    ;   throw_error(domain_error(Pred, H), _)
  526    ).

 test_option(+Option) is semidet

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

  533test_option(Option) :-
  534    test_set_option(Option),
  535    !.
  536test_option(true(_)).
  537test_option(fail).
  538test_option(throws(_)).
  539test_option(all(_)).
  540test_option(set(_)).
  541test_option(nondet).
  542test_option(fixme(_)).
  543test_option(forall(X)) :-
  544    must_be(callable, X).

 test_option(+Option) is semidet

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

  551test_set_option(blocked(X)) :-
  552    must_be(ground, X).
  553test_set_option(condition(X)) :-
  554    must_be(callable, X).
  555test_set_option(setup(X)) :-
  556    must_be(callable, X).
  557test_set_option(cleanup(X)) :-
  558    must_be(callable, X).
  559test_set_option(sto(V)) :-
  560    nonvar(V), member(V, [finite_trees, rational_trees]).
  561test_set_option(concurrent(V)) :-
  562    must_be(boolean, V).
  563
  564
  565                 /*******************************
  566                 *        RUNNING TOPLEVEL      *
  567                 *******************************/
  568
  569:- thread_local
  570    passed/5,                       % Unit, Test, Line, Det, Time
  571    failed/4,                       % Unit, Test, Line, Reason
  572    failed_assertion/7,             % Unit, Test, Line, ALoc, STO, Reason, Goal
  573    blocked/4,                      % Unit, Test, Line, Reason
  574    sto/4,                          % Unit, Test, Line, Results
  575    fixme/5.                        % Unit, Test, Line, Reason, Status
  576
  577:- dynamic
  578    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.

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

 run_tests_in_files(+Files:list) is det

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

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

 make_run_tests(+Files)

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

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

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

Run a single test.

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

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

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

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

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

Run tests on non-deterministic predicates.

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

 result_vars(+Expected, -Vars) is det

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

 1041result_vars(Expected, Vars) :-
 1042    arg(1, Expected, CmpOp),
 1043    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

 1053nondet_compare(all(Cmp), Bindings, _Unit, _Name, _Line) :-
 1054    cmp(Cmp, _Vars, Op, Values),
 1055    cmp_list(Values, Bindings, Op).
 1056nondet_compare(set(Cmp), Bindings0, _Unit, _Name, _Line) :-
 1057    cmp(Cmp, _Vars, Op, Values0),
 1058    sort(Bindings0, Bindings),
 1059    sort(Values0, Values),
 1060    cmp_list(Values, Bindings, Op).
 1061
 1062cmp_list([], [], _Op).
 1063cmp_list([E0|ET], [V0|VT], Op) :-
 1064    call(Op, E0, V0),
 1065    cmp_list(ET, VT, Op).

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

 1069cmp(Var  == Value, Var,  ==, Value).
 1070cmp(Var =:= Value, Var, =:=, Value).
 1071cmp(Var  =  Value, Var,  =,  Value).
 1072:- if(swi). 1073cmp(Var =@= Value, Var, =@=, Value).
 1074:- else. 1075:- if(sicstus). 1076cmp(Var =@= Value, Var, variant, Value). % variant/2 is the same =@=
 1077:- endif. 1078:- endif.

 call_det(:Goal, -Det) is nondet

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

 1086:- if((swi|sicstus)). 1087call_det(Goal, Det) :-
 1088    call_cleanup(Goal,Det0=true),
 1089    ( var(Det0) -> Det = false ; Det = true ).
 1090:- else. 1091call_det(Goal, true) :-
 1092    call(Goal).
 1093:- endif.

 match_error(+Expected, +Received) is semidet

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

 1100match_error(Expect, Rec) :-
 1101    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

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

 call_ex(+Module, +Goal)

Call Goal in Module after applying goal expansion.

 1149call_ex(Module, Goal) :-
 1150    Module:(expand_goal(Goal, GoalEx),
 1151                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.

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

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

 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

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

 running_tests is det

Print the currently running test.

 1263running_tests :-
 1264    running_tests(Running),
 1265    print_message(informational, plunit(running(Running))).
 1266
 1267running_tests(Running) :-
 1268    findall(running(Unit:Test, File:Line, STO, Thread),
 1269            (   running(Unit, Test, Line, STO, Thread),
 1270                unit_file(Unit, File)
 1271            ), Running).

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

True when a test with the specified properties is loaded.

 1278current_test(Unit, Test, Line, Body, Options) :-
 1279    current_unit(Unit, Module, _Supers, _UnitOptions),
 1280    Module:'unit test'(Test, Line, Options, Body).

 check_for_test_errors is semidet

True if there are no errors, otherwise false.

 1286check_for_test_errors :-
 1287    number_of_clauses(failed/4, Failed),
 1288    number_of_clauses(failed_assertion/7, FailedAssertion),
 1289    number_of_clauses(sto/4, STO),
 1290    Failed+FailedAssertion+STO =:= 0.     % fail on errors

 report is det

Print a summary of the tests that ran.

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

 test_report(What) is det

Produce reports on test results after the run.

 1382test_report(fixme) :-
 1383    !,
 1384    report_fixme(TuplesF, TuplesP, TuplesN),
 1385    append([TuplesF, TuplesP, TuplesN], Tuples),
 1386    print_message(informational, plunit(fixme(Tuples))).
 1387test_report(What) :-
 1388    throw_error(domain_error(report_class, What), _).
 1389
 1390
 1391                 /*******************************
 1392                 *             INFO             *
 1393                 *******************************/

 current_test_set(?Unit) is nondet

True if Unit is a currently loaded test-set.

 1399current_test_set(Unit) :-
 1400    current_unit(Unit, _Module, _Context, _Options).

 unit_file(+Unit, -File) is det

unit_file(-Unit, +File) is nondet

 1405unit_file(Unit, File) :-
 1406    current_unit(Unit, Module, _Context, _Options),
 1407    current_module(Module, File).
 1408unit_file(Unit, PlFile) :-
 1409    nonvar(PlFile),
 1410    test_file_for(TestFile, PlFile),
 1411    current_module(Module, TestFile),
 1412    current_unit(Unit, Module, _Context, _Options).
 1413
 1414
 1415                 /*******************************
 1416                 *             FILES            *
 1417                 *******************************/

 load_test_files(+Options) is det

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

 1423load_test_files(_Options) :-
 1424    (   source_file(File),
 1425        file_name_extension(Base, Old, File),
 1426        Old \== plt,
 1427        file_name_extension(Base, plt, TestFile),
 1428        exists_file(TestFile),
 1429        (   test_file_for(TestFile, File)
 1430        ->  true
 1431        ;   load_files(TestFile,
 1432                       [ if(changed),
 1433                         imports([])
 1434                       ]),
 1435            asserta(test_file_for(TestFile, File))
 1436        ),
 1437        fail ; true
 1438    ).
 1439
 1440
 1441
 1442                 /*******************************
 1443                 *           MESSAGES           *
 1444                 *******************************/

 info(+Term)

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

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