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

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

 current_test_flag(?Name, ?Value) is nondet

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

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

 set_test_flag(+Name, +Value) is det

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

 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.

  228set_test_options(Options) :-
  229    valid_options(Options, global_test_option),
  230    set_test_flag(test_options, Options).
  231
  232global_test_option(load(Load)) :-
  233    must_be(oneof([never,always,normal]), Load).
  234global_test_option(run(When)) :-
  235    must_be(oneof([manual,make,make(all)]), When).
  236global_test_option(silent(Bool)) :-
  237    must_be(boolean, Bool).
  238global_test_option(sto(Bool)) :-
  239    must_be(boolean, Bool).
  240global_test_option(cleanup(Bool)) :-
  241    must_be(boolean, Bool).

 loading_tests

True if tests must be loaded.

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

 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).

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

 end_tests(+Name) is det

Close a unit-test module.

To be done

- Run tests/clean module?

- End of file?

  333end_tests(Unit) :-
  334    loading_unit(StartUnit, _, _, _),
  335    !,
  336    (   Unit == StartUnit
  337    ->  once(retract(loading_unit(StartUnit, _, _, Old))),
  338        '$set_source_module'(_, Old)
  339    ;   throw_error(context_error(plunit_close(Unit, StartUnit)), _)
  340    ).
  341end_tests(Unit) :-
  342    throw_error(context_error(plunit_close(Unit, -)), _).

 make_unit_module(+Name, -ModuleName) is det

 unit_module(+Name, -ModuleName) is det

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

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

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

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

 expand(+Term, -Clauses) is semidet

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

 valid_options(+Options, :Pred) is det

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

throws

- type_error or instantiation_error.

  506valid_options(Options, Pred) :-
  507    must_be(list, Options),
  508    verify_options(Options, Pred).
  509
  510verify_options([], _).
  511verify_options([H|T], Pred) :-
  512    (   call(Pred, H)
  513    ->  verify_options(T, Pred)
  514    ;   throw_error(domain_error(Pred, H), _)
  515    ).

 test_option(+Option) is semidet

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

  522test_option(Option) :-
  523    test_set_option(Option),
  524    !.
  525test_option(true(_)).
  526test_option(fail).
  527test_option(throws(_)).
  528test_option(all(_)).
  529test_option(set(_)).
  530test_option(nondet).
  531test_option(fixme(_)).
  532test_option(forall(X)) :-
  533    must_be(callable, X).

 test_option(+Option) is semidet

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

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

 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.

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

 run_tests_in_files(+Files:list) is det

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

  673run_tests_in_files(Files) :-
  674    findall(Unit, unit_in_files(Files, Unit), Units),
  675    (   Units == []
  676    ->  true
  677    ;   run_tests(Units)
  678    ).
  679
  680unit_in_files(Files, Unit) :-
  681    is_list(Files),
  682    !,
  683    member(F, Files),
  684    absolute_file_name(F, Source,
  685                       [ file_type(prolog),
  686                         access(read),
  687                         file_errors(fail)
  688                       ]),
  689    unit_file(Unit, Source).
  690
  691
  692                 /*******************************
  693                 *         HOOKING MAKE/0       *
  694                 *******************************/

 make_run_tests(+Files)

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

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

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

Run a single test.

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

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

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

 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)

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

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

Run tests on non-deterministic predicates.

  998nondet_test(Expected, Unit, Name, Line, Options, Body, Result) :-
  999    unit_module(Unit, Module),
 1000    result_vars(Expected, Vars),
 1001    statistics(runtime, [T0,_]),
 1002    (   setup(Module, test(Unit,Name,Line), Options)
 1003    ->  (   catch(findall(Vars, Module:Body, Bindings), E, true)
 1004        ->  (   var(E)
 1005            ->  statistics(runtime, [T1,_]),
 1006                Time is (T1 - T0)/1000.0,
 1007                (   nondet_compare(Expected, Bindings, Unit, Name, Line)
 1008                ->  Result = success(Unit, Name, Line, true, Time)
 1009                ;   Result = failure(Unit, Name, Line, wrong_answer(Expected, Bindings))
 1010                ),
 1011                cleanup(Module, Options)
 1012            ;   Result = failure(Unit, Name, Line, E),
 1013                cleanup(Module, Options)
 1014            )
 1015        )
 1016    ;   Result = setup_failed(Unit, Name, Line)
 1017    ).

 result_vars(+Expected, -Vars) is det

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

 1025result_vars(Expected, Vars) :-
 1026    arg(1, Expected, CmpOp),
 1027    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

 1037nondet_compare(all(Cmp), Bindings, _Unit, _Name, _Line) :-
 1038    cmp(Cmp, _Vars, Op, Values),
 1039    cmp_list(Values, Bindings, Op).
 1040nondet_compare(set(Cmp), Bindings0, _Unit, _Name, _Line) :-
 1041    cmp(Cmp, _Vars, Op, Values0),
 1042    sort(Bindings0, Bindings),
 1043    sort(Values0, Values),
 1044    cmp_list(Values, Bindings, Op).
 1045
 1046cmp_list([], [], _Op).
 1047cmp_list([E0|ET], [V0|VT], Op) :-
 1048    call(Op, E0, V0),
 1049    cmp_list(ET, VT, Op).

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

 1053cmp(Var  == Value, Var,  ==, Value).
 1054cmp(Var =:= Value, Var, =:=, Value).
 1055cmp(Var  =  Value, Var,  =,  Value).
 1056:- if(swi). 1057cmp(Var =@= Value, Var, =@=, Value).
 1058:- else. 1059:- if(sicstus). 1060cmp(Var =@= Value, Var, variant, Value). % variant/2 is the same =@=
 1061:- endif. 1062:- endif.

 call_det(:Goal, -Det) is nondet

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

 1070:- if((swi|sicstus)). 1071call_det(Goal, Det) :-
 1072    call_cleanup(Goal,Det0=true),
 1073    ( var(Det0) -> Det = false ; Det = true ).
 1074:- else. 1075call_det(Goal, true) :-
 1076    call(Goal).
 1077:- endif.

 match_error(+Expected, +Received) is semidet

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

 1084match_error(Expect, Rec) :-
 1085    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

 1098setup(Module, Context, Options) :-
 1099    option(condition(Condition), Options),
 1100    option(setup(Setup), Options),
 1101    !,
 1102    setup(Module, Context, [condition(Condition)]),
 1103    setup(Module, Context, [setup(Setup)]).
 1104setup(Module, Context, Options) :-
 1105    option(setup(Setup), Options),
 1106    !,
 1107    (   catch(call_ex(Module, Setup), E, true)
 1108    ->  (   var(E)
 1109        ->  true
 1110        ;   print_message(error, plunit(error(setup, Context, E))),
 1111            fail
 1112        )
 1113    ;   print_message(error, error(goal_failed(Setup), _)),
 1114        fail
 1115    ).
 1116setup(Module, Context, Options) :-
 1117    option(condition(Setup), Options),
 1118    !,
 1119    (   catch(call_ex(Module, Setup), E, true)
 1120    ->  (   var(E)
 1121        ->  true
 1122        ;   print_message(error, plunit(error(condition, Context, E))),
 1123            fail
 1124        )
 1125    ;   fail
 1126    ).
 1127setup(_,_,_).

 call_ex(+Module, +Goal)

Call Goal in Module after applying goal expansion.

 1133call_ex(Module, Goal) :-
 1134    Module:(expand_goal(Goal, GoalEx),
 1135                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.

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

 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.

 1198:- if(swi). 1199assert_cyclic(Term) :-
 1200    acyclic_term(Term),
 1201    !,
 1202    assert(Term).
 1203assert_cyclic(Term) :-
 1204    Term =.. [Functor|Args],
 1205    recorda(cyclic, Args, Id),
 1206    functor(Term, _, Arity),
 1207    length(NewArgs, Arity),
 1208    Head =.. [Functor|NewArgs],
 1209    assert((Head :- recorded(_, Var, Id), Var = NewArgs)).
 1210:- else. 1211:- if(sicstus). 1212:- endif. 1213assert_cyclic(Term) :-
 1214    assert(Term).
 1215:- endif. 1216
 1217
 1218                 /*******************************
 1219                 *            REPORTING         *
 1220                 *******************************/

 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

 1233begin_test(Unit, Test, Line, STO) :-
 1234    thread_self(Me),
 1235    assert(running(Unit, Test, Line, STO, Me)),
 1236    unit_file(Unit, File),
 1237    print_message(silent, plunit(begin(Unit:Test, File:Line, STO))).
 1238
 1239end_test(Unit, Test, Line, STO) :-
 1240    thread_self(Me),
 1241    retractall(running(_,_,_,_,Me)),
 1242    unit_file(Unit, File),
 1243    print_message(silent, plunit(end(Unit:Test, File:Line, STO))).

 running_tests is det

Print the currently running test.

 1249running_tests :-
 1250    running_tests(Running),
 1251    print_message(informational, plunit(running(Running))).
 1252
 1253running_tests(Running) :-
 1254    findall(running(Unit:Test, File:Line, STO, Thread),
 1255            (   running(Unit, Test, Line, STO, Thread),
 1256                unit_file(Unit, File)
 1257            ), Running).

 check_for_test_errors is semidet

True if there are no errors, otherwise false.

 1264check_for_test_errors :-
 1265    number_of_clauses(failed/4, Failed),
 1266    number_of_clauses(failed_assertion/7, FailedAssertion),
 1267    number_of_clauses(sto/4, STO),
 1268    Failed+FailedAssertion+STO =:= 0.     % fail on errors

 report is det

Print a summary of the tests that ran.

 1275report :-
 1276    number_of_clauses(passed/5, Passed),
 1277    number_of_clauses(failed/4, Failed),
 1278    number_of_clauses(failed_assertion/7, FailedAssertion),
 1279    number_of_clauses(blocked/4, Blocked),
 1280    number_of_clauses(sto/4, STO),
 1281    (   Passed+Failed+FailedAssertion+Blocked+STO =:= 0
 1282    ->  info(plunit(no_tests))
 1283    ;   Failed+FailedAssertion+Blocked+STO =:= 0
 1284    ->  report_fixme,
 1285        info(plunit(all_passed(Passed)))
 1286    ;   report_blocked,
 1287        report_fixme,
 1288        report_failed_assertions,
 1289        report_failed,
 1290        report_sto,
 1291        info(plunit(passed(Passed)))
 1292    ).
 1293
 1294number_of_clauses(F/A,N) :-
 1295    (   current_predicate(F/A)
 1296    ->  functor(G,F,A),
 1297        findall(t, G, Ts),
 1298        length(Ts, N)
 1299    ;   N = 0
 1300    ).
 1301
 1302report_blocked :-
 1303    number_of_clauses(blocked/4,N),
 1304    N > 0,
 1305    !,
 1306    info(plunit(blocked(N))),
 1307    (   blocked(Unit, Name, Line, Reason),
 1308        unit_file(Unit, File),
 1309        print_message(informational,
 1310                      plunit(blocked(File:Line, Name, Reason))),
 1311        fail ; true
 1312    ).
 1313report_blocked.
 1314
 1315report_failed :-
 1316    number_of_clauses(failed/4, N),
 1317    info(plunit(failed(N))).
 1318
 1319report_failed_assertions :-
 1320    number_of_clauses(failed_assertion/7, N),
 1321    info(plunit(failed_assertions(N))).
 1322
 1323report_sto :-
 1324    number_of_clauses(sto/4, N),
 1325    info(plunit(sto(N))).
 1326
 1327report_fixme :-
 1328    report_fixme(_,_,_).
 1329
 1330report_fixme(TuplesF, TuplesP, TuplesN) :-
 1331    fixme(failed, TuplesF, Failed),
 1332    fixme(passed, TuplesP, Passed),
 1333    fixme(nondet, TuplesN, Nondet),
 1334    print_message(informational, plunit(fixme(Failed, Passed, Nondet))).
 1335
 1336
 1337fixme(How, Tuples, Count) :-
 1338    findall(fixme(Unit, Name, Line, Reason, How),
 1339            fixme(Unit, Name, Line, Reason, How), Tuples),
 1340    length(Tuples, Count).
 1341
 1342
 1343report_failure(_, _, _, assertion, _) :-
 1344    !,
 1345    put_char(user_error, 'A').
 1346report_failure(Unit, Name, Line, Error, _Options) :-
 1347    print_message(error, plunit(failed(Unit, Name, Line, Error))).

 test_report(What) is det

Produce reports on test results after the run.

 1354test_report(fixme) :-
 1355    !,
 1356    report_fixme(TuplesF, TuplesP, TuplesN),
 1357    append([TuplesF, TuplesP, TuplesN], Tuples),
 1358    print_message(informational, plunit(fixme(Tuples))).
 1359test_report(What) :-
 1360    throw_error(domain_error(report_class, What), _).
 1361
 1362
 1363                 /*******************************
 1364                 *             INFO             *
 1365                 *******************************/

 current_test_set(?Unit) is nondet

True if Unit is a currently loaded test-set.

 1371current_test_set(Unit) :-
 1372    current_unit(Unit, _Module, _Context, _Options).

 unit_file(+Unit, -File) is det

unit_file(-Unit, +File) is nondet

 1377unit_file(Unit, File) :-
 1378    current_unit(Unit, Module, _Context, _Options),
 1379    current_module(Module, File).
 1380unit_file(Unit, PlFile) :-
 1381    nonvar(PlFile),
 1382    test_file_for(TestFile, PlFile),
 1383    current_module(Module, TestFile),
 1384    current_unit(Unit, Module, _Context, _Options).
 1385
 1386
 1387                 /*******************************
 1388                 *             FILES            *
 1389                 *******************************/

 load_test_files(+Options) is det

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

 1395load_test_files(_Options) :-
 1396    (   source_file(File),
 1397        file_name_extension(Base, Old, File),
 1398        Old \== plt,
 1399        file_name_extension(Base, plt, TestFile),
 1400        exists_file(TestFile),
 1401        (   test_file_for(TestFile, File)
 1402        ->  true
 1403        ;   load_files(TestFile,
 1404                       [ if(changed),
 1405                         imports([])
 1406                       ]),
 1407            asserta(test_file_for(TestFile, File))
 1408        ),
 1409        fail ; true
 1410    ).
 1411
 1412
 1413
 1414                 /*******************************
 1415                 *           MESSAGES           *
 1416                 *******************************/

 info(+Term)

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

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