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(File, _),
  477        expand(Term, Expanded)
  478    ).
  479
  480
  481                 /*******************************
  482                 *             OPTIONS          *
  483                 *******************************/
  484
  485:- if(swi).  486:- else.  487must_be(list, X) :-
  488    !,
  489    (   is_list(X)
  490    ->  true
  491    ;   is_not(list, X)
  492    ).
  493must_be(Type, X) :-
  494    (   call(Type, X)
  495    ->  true
  496    ;   is_not(Type, X)
  497    ).
  498
  499is_not(Type, X) :-
  500    (   ground(X)
  501    ->  throw_error(type_error(Type, X), _)
  502    ;   throw_error(instantiation_error, _)
  503    ).
  504:- 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.

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

 test_option(+Option) is semidet

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

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

 test_option(+Option) is semidet

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

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

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

 run_tests_in_files(+Files:list) is det

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

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

 make_run_tests(+Files)

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

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

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

Run a single test.

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

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

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

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

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

Run tests on non-deterministic predicates.

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

 result_vars(+Expected, -Vars) is det

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

 1037result_vars(Expected, Vars) :-
 1038    arg(1, Expected, CmpOp),
 1039    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

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

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

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

 call_det(:Goal, -Det) is nondet

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

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

 match_error(+Expected, +Received) is semidet

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

 1096match_error(Expect, Rec) :-
 1097    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

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

 call_ex(+Module, +Goal)

Call Goal in Module after applying goal expansion.

 1145call_ex(Module, Goal) :-
 1146    Module:(expand_goal(Goal, GoalEx),
 1147                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.

 1154cleanup(Module, Options) :-
 1155    option(cleanup(Cleanup), Options, true),
 1156    (   catch(call_ex(Module, Cleanup), E, true)
 1157    ->  (   var(E)
 1158        ->  true
 1159        ;   print_message(warning, E)
 1160        )
 1161    ;   print_message(warning, goal_failed(Cleanup, '(cleanup handler)'))
 1162    ).
 1163
 1164success(Unit, Name, Line, Det, _Time, Options) :-
 1165    memberchk(fixme(Reason), Options),
 1166    !,
 1167    (   (   Det == true
 1168        ;   memberchk(nondet, Options)
 1169        )
 1170    ->  progress(Unit, Name, nondet),
 1171        Ok = passed
 1172    ;   progress(Unit, Name, fixme),
 1173        Ok = nondet
 1174    ),
 1175    flush_output(user_error),
 1176    assert(fixme(Unit, Name, Line, Reason, Ok)).
 1177success(Unit, Name, Line, _, _, Options) :-
 1178    failed_assertion(Unit, Name, Line, _,_,_,_),
 1179    !,
 1180    failure(Unit, Name, Line, assertion, Options).
 1181success(Unit, Name, Line, Det, Time, Options) :-
 1182    assert(passed(Unit, Name, Line, Det, Time)),
 1183    (   (   Det == true
 1184        ;   memberchk(nondet, Options)
 1185        )
 1186    ->  progress(Unit, Name, passed)
 1187    ;   unit_file(Unit, File),
 1188        print_message(warning, plunit(nondet(File, Line, Name)))
 1189    ).
 1190
 1191failure(Unit, Name, Line, _, Options) :-
 1192    memberchk(fixme(Reason), Options),
 1193    !,
 1194    progress(Unit, Name, failed),
 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    print_message(silent,
 1300                  plunit(summary(plunit{passed:Passed,
 1301                                        failed:Failed,
 1302                                        failed_assertions:FailedAssertion,
 1303                                        blocked:Blocked,
 1304                                        sto:STO}))),
 1305    (   Passed+Failed+FailedAssertion+Blocked+STO =:= 0
 1306    ->  info(plunit(no_tests))
 1307    ;   Failed+FailedAssertion+Blocked+STO =:= 0
 1308    ->  report_fixme,
 1309        info(plunit(all_passed(Passed)))
 1310    ;   report_blocked,
 1311        report_fixme,
 1312        report_failed_assertions,
 1313        report_failed,
 1314        report_sto,
 1315        info(plunit(passed(Passed)))
 1316    ).
 1317
 1318number_of_clauses(F/A,N) :-
 1319    (   current_predicate(F/A)
 1320    ->  functor(G,F,A),
 1321        findall(t, G, Ts),
 1322        length(Ts, N)
 1323    ;   N = 0
 1324    ).
 1325
 1326report_blocked :-
 1327    number_of_clauses(blocked/4,N),
 1328    N > 0,
 1329    !,
 1330    info(plunit(blocked(N))),
 1331    (   blocked(Unit, Name, Line, Reason),
 1332        unit_file(Unit, File),
 1333        print_message(informational,
 1334                      plunit(blocked(File:Line, Name, Reason))),
 1335        fail ; true
 1336    ).
 1337report_blocked.
 1338
 1339report_failed :-
 1340    number_of_clauses(failed/4, N),
 1341    info(plunit(failed(N))).
 1342
 1343report_failed_assertions :-
 1344    number_of_clauses(failed_assertion/7, N),
 1345    info(plunit(failed_assertions(N))).
 1346
 1347report_sto :-
 1348    number_of_clauses(sto/4, N),
 1349    info(plunit(sto(N))).
 1350
 1351report_fixme :-
 1352    report_fixme(_,_,_).
 1353
 1354report_fixme(TuplesF, TuplesP, TuplesN) :-
 1355    fixme(failed, TuplesF, Failed),
 1356    fixme(passed, TuplesP, Passed),
 1357    fixme(nondet, TuplesN, Nondet),
 1358    print_message(informational, plunit(fixme(Failed, Passed, Nondet))).
 1359
 1360
 1361fixme(How, Tuples, Count) :-
 1362    findall(fixme(Unit, Name, Line, Reason, How),
 1363            fixme(Unit, Name, Line, Reason, How), Tuples),
 1364    length(Tuples, Count).
 1365
 1366
 1367report_failure(Unit, Name, _, assertion, _) :-
 1368    !,
 1369    progress(Unit, Name, assertion).
 1370report_failure(Unit, Name, Line, Error, _Options) :-
 1371    print_message(error, plunit(failed(Unit, Name, Line, Error))).

 test_report(What) is det

Produce reports on test results after the run.

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

 current_test_set(?Unit) is nondet

True if Unit is a currently loaded test-set.

 1395current_test_set(Unit) :-
 1396    current_unit(Unit, _Module, _Context, _Options).

 unit_file(+Unit, -File) is det

unit_file(-Unit, +File) is nondet

 1401unit_file(Unit, File) :-
 1402    current_unit(Unit, Module, _Context, _Options),
 1403    current_module(Module, File).
 1404unit_file(Unit, PlFile) :-
 1405    nonvar(PlFile),
 1406    test_file_for(TestFile, PlFile),
 1407    current_module(Module, TestFile),
 1408    current_unit(Unit, Module, _Context, _Options).
 1409
 1410
 1411                 /*******************************
 1412                 *             FILES            *
 1413                 *******************************/

 load_test_files(+Options) is det

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

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

 info(+Term)

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

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