plunit.pl

View source with formatted comments or as raw
    1/*  Part of SWI-Prolog
    2
    3    Author:        Jan Wielemaker
    4    E-mail:        J.Wielemaker@vu.nl
    5    WWW:           http://www.swi-prolog.org
    6    Copyright (c)  2006-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          ]).   50
   51/** <module> Unit Testing
   52
   53Unit testing environment for SWI-Prolog and   SICStus Prolog. For usage,
   54please visit http://www.swi-prolog.org/pldoc/package/plunit.
   55*/
   56
   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'(_, _).
  151
  152%!  current_test_flag(?Name, ?Value) is nondet.
  153%
  154%   Query  flags  that  control  the    testing   process.  Emulates
  155%   SWI-Prologs flags.
  156
  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).
  167
  168
  169%!  set_test_flag(+Name, +Value) is det.
  170
  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   ).  198
  199%!  set_test_options(+Options)
  200%
  201%   Specifies how to deal with test suites.  Defined options are:
  202%
  203%           * load(+Load)
  204%           Whether or not the tests must be loaded.  Values are
  205%           =never=, =always=, =normal= (only if not optimised)
  206%
  207%           * run(+When)
  208%           When the tests are run.  Values are =manual=, =make=
  209%           or make(all).
  210%
  211%           * silent(+Bool)
  212%           If =true= (default =false=), report successful tests
  213%           using message level =silent=, only printing errors and
  214%           warnings.
  215%
  216%           * sto(+Bool)
  217%           How to test whether code is subject to occurs check
  218%           (STO).  If =false= (default), STO is not considered.
  219%           If =true= and supported by the hosting Prolog, code
  220%           is run in all supported unification mode and reported
  221%           if the results are inconsistent.
  222%
  223%           * cleanup(+Bool)
  224%           If =true= (default =false), cleanup report at the end
  225%           of run_tests/1.  Used to improve cooperation with
  226%           memory debuggers such as dmalloc.
  227%
  228%           * concurrent(+Bool)
  229%           If =true= (default =false), run all tests in a block
  230%           concurrently.
  231%
  232
  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).
  249
  250
  251%!  loading_tests
  252%
  253%   True if tests must be loaded.
  254
  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
  272
  273%!  begin_tests(+UnitName:atom) is det.
  274%!  begin_tests(+UnitName:atom, Options) is det.
  275%
  276%   Start a test-unit. UnitName is the  name   of  the test set. the
  277%   unit is ended by :- end_tests(UnitName).
  278
  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.  333
  334%!  end_tests(+Name) is det.
  335%
  336%   Close a unit-test module.
  337%
  338%   @tbd    Run tests/clean module?
  339%   @tbd    End of file?
  340
  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, -)), _).
  351
  352%!  make_unit_module(+Name, -ModuleName) is det.
  353%!  unit_module(+Name, -ModuleName) is det.
  354
  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                 *******************************/
  389
  390%!  expand_test(+Name, +Options, +Body, -Clause) is det.
  391%
  392%   Expand test(Name, Options) :-  Body  into   a  clause  for
  393%   'unit test'/4 and 'unit body'/2.
  394
  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(_)).
  442
  443
  444%!  expand(+Term, -Clauses) is semidet.
  445
  446expand(end_of_file, _) :-
  447    loading_unit(Unit, _, _, _),
  448    !,
  449    end_tests(Unit),                % warn?
  450    fail.
  451expand((:-end_tests(_)), _) :-
  452    !,
  453    fail.
  454expand(_Term, []) :-
  455    \+ loading_tests.
  456expand((test(Name) :- Body), Clauses) :-
  457    !,
  458    expand_test(Name, [], Body, Clauses).
  459expand((test(Name, Options) :- Body), Clauses) :-
  460    !,
  461    expand_test(Name, Options, Body, Clauses).
  462expand(test(Name), _) :-
  463    !,
  464    throw_error(existence_error(body, test(Name)), _).
  465expand(test(Name, _Options), _) :-
  466    !,
  467    throw_error(existence_error(body, test(Name)), _).
  468
  469:- if(swi).  470:- multifile
  471    system:term_expansion/2.  472:- endif.  473
  474system:term_expansion(Term, Expanded) :-
  475    (   loading_unit(_, _, File, _)
  476    ->  source_location(ThisFile, _),
  477        (   File == ThisFile
  478        ->  true
  479        ;   source_file_property(ThisFile, included_in(File, _))
  480        ),
  481        expand(Term, Expanded)
  482    ).
  483
  484
  485                 /*******************************
  486                 *             OPTIONS          *
  487                 *******************************/
  488
  489:- if(swi).  490:- else.  491must_be(list, X) :-
  492    !,
  493    (   is_list(X)
  494    ->  true
  495    ;   is_not(list, X)
  496    ).
  497must_be(Type, X) :-
  498    (   call(Type, X)
  499    ->  true
  500    ;   is_not(Type, X)
  501    ).
  502
  503is_not(Type, X) :-
  504    (   ground(X)
  505    ->  throw_error(type_error(Type, X), _)
  506    ;   throw_error(instantiation_error, _)
  507    ).
  508:- endif.  509
  510%!  valid_options(+Options, :Pred) is det.
  511%
  512%   Verify Options to be a list of valid options according to
  513%   Pred.
  514%
  515%   @throws =type_error= or =instantiation_error=.
  516
  517valid_options(Options, Pred) :-
  518    must_be(list, Options),
  519    verify_options(Options, Pred).
  520
  521verify_options([], _).
  522verify_options([H|T], Pred) :-
  523    (   call(Pred, H)
  524    ->  verify_options(T, Pred)
  525    ;   throw_error(domain_error(Pred, H), _)
  526    ).
  527
  528
  529%!  test_option(+Option) is semidet.
  530%
  531%   True if Option is a valid option for test(Name, Options).
  532
  533test_option(Option) :-
  534    test_set_option(Option),
  535    !.
  536test_option(true(_)).
  537test_option(fail).
  538test_option(throws(_)).
  539test_option(all(_)).
  540test_option(set(_)).
  541test_option(nondet).
  542test_option(fixme(_)).
  543test_option(forall(X)) :-
  544    must_be(callable, X).
  545
  546%!  test_option(+Option) is semidet.
  547%
  548%   True if Option is a valid option for :- begin_tests(Name,
  549%   Options).
  550
  551test_set_option(blocked(X)) :-
  552    must_be(ground, X).
  553test_set_option(condition(X)) :-
  554    must_be(callable, X).
  555test_set_option(setup(X)) :-
  556    must_be(callable, X).
  557test_set_option(cleanup(X)) :-
  558    must_be(callable, X).
  559test_set_option(sto(V)) :-
  560    nonvar(V), member(V, [finite_trees, rational_trees]).
  561test_set_option(concurrent(V)) :-
  562    must_be(boolean, V).
  563
  564
  565                 /*******************************
  566                 *        RUNNING TOPLEVEL      *
  567                 *******************************/
  568
  569:- thread_local
  570    passed/5,                       % Unit, Test, Line, Det, Time
  571    failed/4,                       % Unit, Test, Line, Reason
  572    failed_assertion/7,             % Unit, Test, Line, ALoc, STO, Reason, Goal
  573    blocked/4,                      % Unit, Test, Line, Reason
  574    sto/4,                          % Unit, Test, Line, Results
  575    fixme/5.                        % Unit, Test, Line, Reason, Status
  576
  577:- dynamic
  578    running/5.                      % Unit, Test, Line, STO, Thread
  579
  580%!  run_tests is semidet.
  581%!  run_tests(+TestSet) is semidet.
  582%
  583%   Run  tests  and  report  about    the   results.  The  predicate
  584%   run_tests/0 runs all known  tests  that   are  not  blocked. The
  585%   predicate run_tests/1 takes a  specification   of  tests to run.
  586%   This  is  either  a  single   specification    or   a   list  of
  587%   specifications. Each single specification is  either the name of
  588%   a test-unit or a term <test-unit>:<test>, denoting a single test
  589%   within a unit.
  590
  591run_tests :-
  592    cleanup,
  593    setup_call_cleanup(
  594        setup_trap_assertions(Ref),
  595        run_current_units,
  596        report_and_cleanup(Ref)).
  597
  598run_current_units :-
  599    forall(current_test_set(Set),
  600           run_unit(Set)),
  601    check_for_test_errors.
  602
  603report_and_cleanup(Ref) :-
  604    cleanup_trap_assertions(Ref),
  605    report,
  606    cleanup_after_test.
  607
  608run_tests(Set) :-
  609    cleanup,
  610    setup_call_cleanup(
  611        setup_trap_assertions(Ref),
  612        run_unit_and_check_errors(Set),
  613        report_and_cleanup(Ref)).
  614
  615run_unit_and_check_errors(Set) :-
  616    run_unit(Set),
  617    check_for_test_errors.
  618
  619run_unit([]) :- !.
  620run_unit([H|T]) :-
  621    !,
  622    run_unit(H),
  623    run_unit(T).
  624run_unit(Spec) :-
  625    unit_from_spec(Spec, Unit, Tests, Module, UnitOptions),
  626    (   option(blocked(Reason), UnitOptions)
  627    ->  info(plunit(blocked(unit(Unit, Reason))))
  628    ;   setup(Module, unit(Unit), UnitOptions)
  629    ->  info(plunit(begin(Spec))),
  630        current_test_flag(test_options, GlobalOptions),
  631        (   option(concurrent(true), GlobalOptions),
  632            option(concurrent(true), UnitOptions, false)
  633        ->  concurrent_forall((Module:'unit test'(Name, Line, Options, Body),
  634                               matching_test(Name, Tests)),
  635                              run_test(Unit, Name, Line, Options, Body))
  636        ;   forall((Module:'unit test'(Name, Line, Options, Body),
  637                    matching_test(Name, Tests)),
  638                   run_test(Unit, Name, Line, Options, Body))),
  639        info(plunit(end(Spec))),
  640        (   message_level(silent)
  641        ->  true
  642        ;   format(user_error, '~N', [])
  643        ),
  644        cleanup(Module, UnitOptions)
  645    ;   true
  646    ).
  647
  648unit_from_spec(Unit, Unit, _, Module, Options) :-
  649    atom(Unit),
  650    !,
  651    (   current_unit(Unit, Module, _Supers, Options)
  652    ->  true
  653    ;   throw_error(existence_error(unit_test, Unit), _)
  654    ).
  655unit_from_spec(Unit:Tests, Unit, Tests, Module, Options) :-
  656    atom(Unit),
  657    !,
  658    (   current_unit(Unit, Module, _Supers, Options)
  659    ->  true
  660    ;   throw_error(existence_error(unit_test, Unit), _)
  661    ).
  662
  663
  664matching_test(X, X) :- !.
  665matching_test(Name, Set) :-
  666    is_list(Set),
  667    memberchk(Name, Set).
  668
  669cleanup :-
  670    thread_self(Me),
  671    retractall(passed(_, _, _, _, _)),
  672    retractall(failed(_, _, _, _)),
  673    retractall(failed_assertion(_, _, _, _, _, _, _)),
  674    retractall(blocked(_, _, _, _)),
  675    retractall(sto(_, _, _, _)),
  676    retractall(fixme(_, _, _, _, _)),
  677    retractall(running(_,_,_,_,Me)).
  678
  679cleanup_after_test :-
  680    current_test_flag(test_options, Options),
  681    option(cleanup(Cleanup), Options, false),
  682    (   Cleanup == true
  683    ->  cleanup
  684    ;   true
  685    ).
  686
  687
  688%!  run_tests_in_files(+Files:list) is det.
  689%
  690%   Run all test-units that appear in the given Files.
  691
  692run_tests_in_files(Files) :-
  693    findall(Unit, unit_in_files(Files, Unit), Units),
  694    (   Units == []
  695    ->  true
  696    ;   run_tests(Units)
  697    ).
  698
  699unit_in_files(Files, Unit) :-
  700    is_list(Files),
  701    !,
  702    member(F, Files),
  703    absolute_file_name(F, Source,
  704                       [ file_type(prolog),
  705                         access(read),
  706                         file_errors(fail)
  707                       ]),
  708    unit_file(Unit, Source).
  709
  710
  711                 /*******************************
  712                 *         HOOKING MAKE/0       *
  713                 *******************************/
  714
  715%!  make_run_tests(+Files)
  716%
  717%   Called indirectly from make/0 after Files have been reloaded.
  718
  719make_run_tests(Files) :-
  720    current_test_flag(test_options, Options),
  721    option(run(When), Options, manual),
  722    (   When == make
  723    ->  run_tests_in_files(Files)
  724    ;   When == make(all)
  725    ->  run_tests
  726    ;   true
  727    ).
  728
  729:- if(swi).  730
  731unification_capability(sto_error_incomplete).
  732% can detect some (almost all) STO runs
  733unification_capability(rational_trees).
  734unification_capability(finite_trees).
  735
  736set_unification_capability(Cap) :-
  737    cap_to_flag(Cap, Flag),
  738    set_prolog_flag(occurs_check, Flag).
  739
  740current_unification_capability(Cap) :-
  741    current_prolog_flag(occurs_check, Flag),
  742    cap_to_flag(Cap, Flag),
  743    !.
  744
  745cap_to_flag(sto_error_incomplete, error).
  746cap_to_flag(rational_trees, false).
  747cap_to_flag(finite_trees, true).
  748
  749:- else.  750:- if(sicstus).  751
  752unification_capability(rational_trees).
  753set_unification_capability(rational_trees).
  754current_unification_capability(rational_trees).
  755
  756:- else.  757
  758unification_capability(_) :-
  759    fail.
  760
  761:- endif.  762:- endif.  763
  764                 /*******************************
  765                 *      ASSERTION HANDLING      *
  766                 *******************************/
  767
  768:- if(swi).  769
  770:- dynamic prolog:assertion_failed/2.  771
  772setup_trap_assertions(Ref) :-
  773    asserta((prolog:assertion_failed(Reason, Goal) :-
  774                    test_assertion_failed(Reason, Goal)),
  775            Ref).
  776
  777cleanup_trap_assertions(Ref) :-
  778    erase(Ref).
  779
  780test_assertion_failed(Reason, Goal) :-
  781    thread_self(Me),
  782    running(Unit, Test, Line, STO, Me),
  783    (   catch(get_prolog_backtrace(10, Stack), _, fail),
  784        assertion_location(Stack, AssertLoc)
  785    ->  true
  786    ;   AssertLoc = unknown
  787    ),
  788    current_test_flag(test_options, Options),
  789    report_failed_assertion(Unit, Test, Line, AssertLoc,
  790                            STO, Reason, Goal, Options),
  791    assert_cyclic(failed_assertion(Unit, Test, Line, AssertLoc,
  792                                   STO, Reason, Goal)).
  793
  794assertion_location(Stack, File:Line) :-
  795    append(_, [AssertFrame,CallerFrame|_], Stack),
  796    prolog_stack_frame_property(AssertFrame,
  797                                predicate(prolog_debug:assertion/1)),
  798    !,
  799    prolog_stack_frame_property(CallerFrame, location(File:Line)).
  800
  801report_failed_assertion(Unit, Test, Line, AssertLoc,
  802                        STO, Reason, Goal, _Options) :-
  803    print_message(
  804        error,
  805        plunit(failed_assertion(Unit, Test, Line, AssertLoc,
  806                                STO, Reason, Goal))).
  807
  808:- else.  809
  810setup_trap_assertions(_).
  811cleanup_trap_assertions(_).
  812
  813:- endif.  814
  815
  816                 /*******************************
  817                 *         RUNNING A TEST       *
  818                 *******************************/
  819
  820%!  run_test(+Unit, +Name, +Line, +Options, +Body) is det.
  821%
  822%   Run a single test.
  823
  824run_test(Unit, Name, Line, Options, Body) :-
  825    option(forall(Generator), Options),
  826    !,
  827    unit_module(Unit, Module),
  828    term_variables(Generator, Vars),
  829    forall(Module:Generator,
  830           run_test_once(Unit, @(Name,Vars), Line, Options, Body)).
  831run_test(Unit, Name, Line, Options, Body) :-
  832    run_test_once(Unit, Name, Line, Options, Body).
  833
  834run_test_once(Unit, Name, Line, Options, Body) :-
  835    current_test_flag(test_options, GlobalOptions),
  836    option(sto(false), GlobalOptions, false),
  837    !,
  838    current_unification_capability(Type),
  839    begin_test(Unit, Name, Line, Type),
  840    run_test_6(Unit, Name, Line, Options, Body, Result),
  841    end_test(Unit, Name, Line, Type),
  842    report_result(Result, Options).
  843run_test_once(Unit, Name, Line, Options, Body) :-
  844    current_unit(Unit, _Module, _Supers, UnitOptions),
  845    option(sto(Type), UnitOptions),
  846    \+ option(sto(_), Options),
  847    !,
  848    current_unification_capability(Cap0),
  849    call_cleanup(run_test_cap(Unit, Name, Line, [sto(Type)|Options], Body),
  850                 set_unification_capability(Cap0)).
  851run_test_once(Unit, Name, Line, Options, Body) :-
  852    current_unification_capability(Cap0),
  853    call_cleanup(run_test_cap(Unit, Name, Line, Options, Body),
  854                 set_unification_capability(Cap0)).
  855
  856run_test_cap(Unit, Name, Line, Options, Body) :-
  857    (   option(sto(Type), Options)
  858    ->  unification_capability(Type),
  859        set_unification_capability(Type),
  860        begin_test(Unit, Name, Line, Type),
  861        run_test_6(Unit, Name, Line, Options, Body, Result),
  862        end_test(Unit, Name, Line, Type),
  863        report_result(Result, Options)
  864    ;   findall(Key-(Type+Result),
  865                test_caps(Type, Unit, Name, Line, Options, Body, Result, Key),
  866                Pairs),
  867        group_pairs_by_key(Pairs, Keyed),
  868        (   Keyed == []
  869        ->  true
  870        ;   Keyed = [_-Results]
  871        ->  Results = [_Type+Result|_],
  872            report_result(Result, Options)          % consistent results
  873        ;   pairs_values(Pairs, ResultByType),
  874            report_result(sto(Unit, Name, Line, ResultByType), Options)
  875        )
  876    ).
  877
  878%!  test_caps(-Type, +Unit, +Name, +Line, +Options, +Body, -Result, -Key) is nondet.
  879
  880test_caps(Type, Unit, Name, Line, Options, Body, Result, Key) :-
  881    unification_capability(Type),
  882    set_unification_capability(Type),
  883    begin_test(Unit, Name, Line, Type),
  884    run_test_6(Unit, Name, Line, Options, Body, Result),
  885    end_test(Unit, Name, Line, Type),
  886    result_to_key(Result, Key),
  887    Key \== setup_failed.
  888
  889result_to_key(blocked(_, _, _, _), blocked).
  890result_to_key(failure(_, _, _, How0), failure(How1)) :-
  891    ( How0 = succeeded(_T) -> How1 = succeeded ; How0 = How1 ).
  892result_to_key(success(_, _, _, Determinism, _), success(Determinism)).
  893result_to_key(setup_failed(_,_,_), setup_failed).
  894
  895report_result(blocked(Unit, Name, Line, Reason), _) :-
  896    !,
  897    assert(blocked(Unit, Name, Line, Reason)).
  898report_result(failure(Unit, Name, Line, How), Options) :-
  899    !,
  900    failure(Unit, Name, Line, How, Options).
  901report_result(success(Unit, Name, Line, Determinism, Time), Options) :-
  902    !,
  903    success(Unit, Name, Line, Determinism, Time, Options).
  904report_result(setup_failed(_Unit, _Name, _Line), _Options).
  905report_result(sto(Unit, Name, Line, ResultByType), Options) :-
  906    assert(sto(Unit, Name, Line, ResultByType)),
  907    print_message(error, plunit(sto(Unit, Name, Line))),
  908    report_sto_results(ResultByType, Options).
  909
  910report_sto_results([], _).
  911report_sto_results([Type+Result|T], Options) :-
  912    print_message(error, plunit(sto(Type, Result))),
  913    report_sto_results(T, Options).
  914
  915
  916%!  run_test_6(+Unit, +Name, +Line, +Options, :Body, -Result) is det.
  917%
  918%   Result is one of:
  919%
  920%           * blocked(Unit, Name, Line, Reason)
  921%           * failure(Unit, Name, Line, How)
  922%           * success(Unit, Name, Line, Determinism, Time)
  923%           * setup_failed(Unit, Name, Line)
  924
  925run_test_6(Unit, Name, Line, Options, _Body,
  926           blocked(Unit, Name, Line, Reason)) :-
  927    option(blocked(Reason), Options),
  928    !.
  929run_test_6(Unit, Name, Line, Options, Body, Result) :-
  930    option(all(Answer), Options),                  % all(Bindings)
  931    !,
  932    nondet_test(all(Answer), Unit, Name, Line, Options, Body, Result).
  933run_test_6(Unit, Name, Line, Options, Body, Result) :-
  934    option(set(Answer), Options),                  % set(Bindings)
  935    !,
  936    nondet_test(set(Answer), Unit, Name, Line, Options, Body, Result).
  937run_test_6(Unit, Name, Line, Options, Body, Result) :-
  938    option(fail, Options),                         % fail
  939    !,
  940    unit_module(Unit, Module),
  941    (   setup(Module, test(Unit,Name,Line), Options)
  942    ->  statistics(runtime, [T0,_]),
  943        (   catch(Module:Body, E, true)
  944        ->  (   var(E)
  945            ->  statistics(runtime, [T1,_]),
  946                Time is (T1 - T0)/1000.0,
  947                Result = failure(Unit, Name, Line, succeeded(Time)),
  948                cleanup(Module, Options)
  949            ;   Result = failure(Unit, Name, Line, E),
  950                cleanup(Module, Options)
  951            )
  952        ;   statistics(runtime, [T1,_]),
  953            Time is (T1 - T0)/1000.0,
  954            Result = success(Unit, Name, Line, true, Time),
  955            cleanup(Module, Options)
  956        )
  957    ;   Result = setup_failed(Unit, Name, Line)
  958    ).
  959run_test_6(Unit, Name, Line, Options, Body, Result) :-
  960    option(true(Cmp), Options),
  961    !,
  962    unit_module(Unit, Module),
  963    (   setup(Module, test(Unit,Name,Line), Options) % true(Binding)
  964    ->  statistics(runtime, [T0,_]),
  965        (   catch(call_det(Module:Body, Det), E, true)
  966        ->  (   var(E)
  967            ->  statistics(runtime, [T1,_]),
  968                Time is (T1 - T0)/1000.0,
  969                (   catch(Module:Cmp, E, true)
  970                ->  (   var(E)
  971                    ->  Result = success(Unit, Name, Line, Det, Time)
  972                    ;   Result = failure(Unit, Name, Line, cmp_error(Cmp, E))
  973                    )
  974                ;   Result = failure(Unit, Name, Line, wrong_answer(Cmp))
  975                ),
  976                cleanup(Module, Options)
  977            ;   Result = failure(Unit, Name, Line, E),
  978                cleanup(Module, Options)
  979            )
  980        ;   Result = failure(Unit, Name, Line, failed),
  981            cleanup(Module, Options)
  982        )
  983    ;   Result = setup_failed(Unit, Name, Line)
  984    ).
  985run_test_6(Unit, Name, Line, Options, Body, Result) :-
  986    option(throws(Expect), Options),
  987    !,
  988    unit_module(Unit, Module),
  989    (   setup(Module, test(Unit,Name,Line), Options)
  990    ->  statistics(runtime, [T0,_]),
  991        (   catch(Module:Body, E, true)
  992        ->  (   var(E)
  993            ->  Result = failure(Unit, Name, Line, no_exception),
  994                cleanup(Module, Options)
  995            ;   statistics(runtime, [T1,_]),
  996                Time is (T1 - T0)/1000.0,
  997                (   match_error(Expect, E)
  998                ->  Result = success(Unit, Name, Line, true, Time)
  999                ;   Result = failure(Unit, Name, Line, wrong_error(Expect, E))
 1000                ),
 1001                cleanup(Module, Options)
 1002            )
 1003        ;   Result = failure(Unit, Name, Line, failed),
 1004            cleanup(Module, Options)
 1005        )
 1006    ;   Result = setup_failed(Unit, Name, Line)
 1007    ).
 1008
 1009
 1010%!  non_det_test(+Expected, +Unit, +Name, +Line, +Options, +Body, -Result)
 1011%
 1012%   Run tests on non-deterministic predicates.
 1013
 1014nondet_test(Expected, Unit, Name, Line, Options, Body, Result) :-
 1015    unit_module(Unit, Module),
 1016    result_vars(Expected, Vars),
 1017    statistics(runtime, [T0,_]),
 1018    (   setup(Module, test(Unit,Name,Line), Options)
 1019    ->  (   catch(findall(Vars, Module:Body, Bindings), E, true)
 1020        ->  (   var(E)
 1021            ->  statistics(runtime, [T1,_]),
 1022                Time is (T1 - T0)/1000.0,
 1023                (   nondet_compare(Expected, Bindings, Unit, Name, Line)
 1024                ->  Result = success(Unit, Name, Line, true, Time)
 1025                ;   Result = failure(Unit, Name, Line, wrong_answer(Expected, Bindings))
 1026                ),
 1027                cleanup(Module, Options)
 1028            ;   Result = failure(Unit, Name, Line, E),
 1029                cleanup(Module, Options)
 1030            )
 1031        )
 1032    ;   Result = setup_failed(Unit, Name, Line)
 1033    ).
 1034
 1035
 1036%!  result_vars(+Expected, -Vars) is det.
 1037%
 1038%   Create a term v(V1, ...) containing all variables at the left
 1039%   side of the comparison operator on Expected.
 1040
 1041result_vars(Expected, Vars) :-
 1042    arg(1, Expected, CmpOp),
 1043    arg(1, CmpOp, Vars).
 1044
 1045%!  nondet_compare(+Expected, +Bindings, +Unit, +Name, +Line) is semidet.
 1046%
 1047%   Compare list/set results for non-deterministic predicates.
 1048%
 1049%   @tbd    Properly report errors
 1050%   @bug    Sort should deal with equivalence on the comparison
 1051%           operator.
 1052
 1053nondet_compare(all(Cmp), Bindings, _Unit, _Name, _Line) :-
 1054    cmp(Cmp, _Vars, Op, Values),
 1055    cmp_list(Values, Bindings, Op).
 1056nondet_compare(set(Cmp), Bindings0, _Unit, _Name, _Line) :-
 1057    cmp(Cmp, _Vars, Op, Values0),
 1058    sort(Bindings0, Bindings),
 1059    sort(Values0, Values),
 1060    cmp_list(Values, Bindings, Op).
 1061
 1062cmp_list([], [], _Op).
 1063cmp_list([E0|ET], [V0|VT], Op) :-
 1064    call(Op, E0, V0),
 1065    cmp_list(ET, VT, Op).
 1066
 1067%!  cmp(+CmpTerm, -Left, -Op, -Right) is det.
 1068
 1069cmp(Var  == Value, Var,  ==, Value).
 1070cmp(Var =:= Value, Var, =:=, Value).
 1071cmp(Var  =  Value, Var,  =,  Value).
 1072:- if(swi). 1073cmp(Var =@= Value, Var, =@=, Value).
 1074:- else. 1075:- if(sicstus). 1076cmp(Var =@= Value, Var, variant, Value). % variant/2 is the same =@=
 1077:- endif. 1078:- endif. 1079
 1080
 1081%!  call_det(:Goal, -Det) is nondet.
 1082%
 1083%   True if Goal succeeded.  Det is unified to =true= if Goal left
 1084%   no choicepoints and =false= otherwise.
 1085
 1086:- if((swi|sicstus)). 1087call_det(Goal, Det) :-
 1088    call_cleanup(Goal,Det0=true),
 1089    ( var(Det0) -> Det = false ; Det = true ).
 1090:- else. 1091call_det(Goal, true) :-
 1092    call(Goal).
 1093:- endif. 1094
 1095%!  match_error(+Expected, +Received) is semidet.
 1096%
 1097%   True if the Received errors matches the expected error. Matching
 1098%   is based on subsumes_term/2.
 1099
 1100match_error(Expect, Rec) :-
 1101    subsumes_term(Expect, Rec).
 1102
 1103%!  setup(+Module, +Context, +Options) is semidet.
 1104%
 1105%   Call the setup handler and  fail  if   it  cannot  run  for some
 1106%   reason. The condition handler is  similar,   but  failing is not
 1107%   considered an error.  Context is one of
 1108%
 1109%       * unit(Unit)
 1110%       If it is the setup handler for a unit
 1111%       * test(Unit,Name,Line)
 1112%       If it is the setup handler for a test
 1113
 1114setup(Module, Context, Options) :-
 1115    option(condition(Condition), Options),
 1116    option(setup(Setup), Options),
 1117    !,
 1118    setup(Module, Context, [condition(Condition)]),
 1119    setup(Module, Context, [setup(Setup)]).
 1120setup(Module, Context, Options) :-
 1121    option(setup(Setup), Options),
 1122    !,
 1123    (   catch(call_ex(Module, Setup), E, true)
 1124    ->  (   var(E)
 1125        ->  true
 1126        ;   print_message(error, plunit(error(setup, Context, E))),
 1127            fail
 1128        )
 1129    ;   print_message(error, error(goal_failed(Setup), _)),
 1130        fail
 1131    ).
 1132setup(Module, Context, Options) :-
 1133    option(condition(Setup), Options),
 1134    !,
 1135    (   catch(call_ex(Module, Setup), E, true)
 1136    ->  (   var(E)
 1137        ->  true
 1138        ;   print_message(error, plunit(error(condition, Context, E))),
 1139            fail
 1140        )
 1141    ;   fail
 1142    ).
 1143setup(_,_,_).
 1144
 1145%!  call_ex(+Module, +Goal)
 1146%
 1147%   Call Goal in Module after applying goal expansion.
 1148
 1149call_ex(Module, Goal) :-
 1150    Module:(expand_goal(Goal, GoalEx),
 1151                GoalEx).
 1152
 1153%!  cleanup(+Module, +Options) is det.
 1154%
 1155%   Call the cleanup handler and succeed.   Failure  or error of the
 1156%   cleanup handler is reported, but tests continue normally.
 1157
 1158cleanup(Module, Options) :-
 1159    option(cleanup(Cleanup), Options, true),
 1160    (   catch(call_ex(Module, Cleanup), E, true)
 1161    ->  (   var(E)
 1162        ->  true
 1163        ;   print_message(warning, E)
 1164        )
 1165    ;   print_message(warning, goal_failed(Cleanup, '(cleanup handler)'))
 1166    ).
 1167
 1168success(Unit, Name, Line, Det, _Time, Options) :-
 1169    memberchk(fixme(Reason), Options),
 1170    !,
 1171    (   (   Det == true
 1172        ;   memberchk(nondet, Options)
 1173        )
 1174    ->  progress(Unit, Name, nondet),
 1175        Ok = passed
 1176    ;   progress(Unit, Name, fixme),
 1177        Ok = nondet
 1178    ),
 1179    flush_output(user_error),
 1180    assert(fixme(Unit, Name, Line, Reason, Ok)).
 1181success(Unit, Name, Line, _, _, Options) :-
 1182    failed_assertion(Unit, Name, Line, _,_,_,_),
 1183    !,
 1184    failure(Unit, Name, Line, assertion, Options).
 1185success(Unit, Name, Line, Det, Time, Options) :-
 1186    assert(passed(Unit, Name, Line, Det, Time)),
 1187    (   (   Det == true
 1188        ;   memberchk(nondet, Options)
 1189        )
 1190    ->  progress(Unit, Name, passed)
 1191    ;   unit_file(Unit, File),
 1192        print_message(warning, plunit(nondet(File, Line, Name)))
 1193    ).
 1194
 1195failure(Unit, Name, Line, _, Options) :-
 1196    memberchk(fixme(Reason), Options),
 1197    !,
 1198    progress(Unit, Name, failed),
 1199    assert(fixme(Unit, Name, Line, Reason, failed)).
 1200failure(Unit, Name, Line, E, Options) :-
 1201    report_failure(Unit, Name, Line, E, Options),
 1202    assert_cyclic(failed(Unit, Name, Line, E)).
 1203
 1204%!  assert_cyclic(+Term) is det.
 1205%
 1206%   Assert  a  possibly  cyclic  unit   clause.  Current  SWI-Prolog
 1207%   assert/1 does not handle cyclic terms,  so we emulate this using
 1208%   the recorded database.
 1209%
 1210%   @tbd    Implement cycle-safe assert and remove this.
 1211
 1212:- if(swi). 1213assert_cyclic(Term) :-
 1214    acyclic_term(Term),
 1215    !,
 1216    assert(Term).
 1217assert_cyclic(Term) :-
 1218    Term =.. [Functor|Args],
 1219    recorda(cyclic, Args, Id),
 1220    functor(Term, _, Arity),
 1221    length(NewArgs, Arity),
 1222    Head =.. [Functor|NewArgs],
 1223    assert((Head :- recorded(_, Var, Id), Var = NewArgs)).
 1224:- else. 1225:- if(sicstus). 1226:- endif. 1227assert_cyclic(Term) :-
 1228    assert(Term).
 1229:- endif. 1230
 1231
 1232                 /*******************************
 1233                 *            REPORTING         *
 1234                 *******************************/
 1235
 1236%!  begin_test(Unit, Test, Line, STO) is det.
 1237%!  end_test(Unit, Test, Line, STO) is det.
 1238%
 1239%   Maintain running/5 and report a test has started/is ended using
 1240%   a =silent= message:
 1241%
 1242%       * plunit(begin(Unit:Test, File:Line, STO))
 1243%       * plunit(end(Unit:Test, File:Line, STO))
 1244%
 1245%   @see message_hook/3 for intercepting these messages
 1246
 1247begin_test(Unit, Test, Line, STO) :-
 1248    thread_self(Me),
 1249    assert(running(Unit, Test, Line, STO, Me)),
 1250    unit_file(Unit, File),
 1251    print_message(silent, plunit(begin(Unit:Test, File:Line, STO))).
 1252
 1253end_test(Unit, Test, Line, STO) :-
 1254    thread_self(Me),
 1255    retractall(running(_,_,_,_,Me)),
 1256    unit_file(Unit, File),
 1257    print_message(silent, plunit(end(Unit:Test, File:Line, STO))).
 1258
 1259%!  running_tests is det.
 1260%
 1261%   Print the currently running test.
 1262
 1263running_tests :-
 1264    running_tests(Running),
 1265    print_message(informational, plunit(running(Running))).
 1266
 1267running_tests(Running) :-
 1268    findall(running(Unit:Test, File:Line, STO, Thread),
 1269            (   running(Unit, Test, Line, STO, Thread),
 1270                unit_file(Unit, File)
 1271            ), Running).
 1272
 1273
 1274%!  current_test(?Unit, ?Test, ?Line, ?Body, ?Options)
 1275%
 1276%   True when a test with the specified properties is loaded.
 1277
 1278current_test(Unit, Test, Line, Body, Options) :-
 1279    current_unit(Unit, Module, _Supers, _UnitOptions),
 1280    Module:'unit test'(Test, Line, Options, Body).
 1281
 1282%!  check_for_test_errors is semidet.
 1283%
 1284%   True if there are no errors, otherwise false.
 1285
 1286check_for_test_errors :-
 1287    number_of_clauses(failed/4, Failed),
 1288    number_of_clauses(failed_assertion/7, FailedAssertion),
 1289    number_of_clauses(sto/4, STO),
 1290    Failed+FailedAssertion+STO =:= 0.     % fail on errors
 1291
 1292
 1293%!  report is det.
 1294%
 1295%   Print a summary of the tests that ran.
 1296
 1297report :-
 1298    number_of_clauses(passed/5, Passed),
 1299    number_of_clauses(failed/4, Failed),
 1300    number_of_clauses(failed_assertion/7, FailedAssertion),
 1301    number_of_clauses(blocked/4, Blocked),
 1302    number_of_clauses(sto/4, STO),
 1303    print_message(silent,
 1304                  plunit(summary(plunit{passed:Passed,
 1305                                        failed:Failed,
 1306                                        failed_assertions:FailedAssertion,
 1307                                        blocked:Blocked,
 1308                                        sto:STO}))),
 1309    (   Passed+Failed+FailedAssertion+Blocked+STO =:= 0
 1310    ->  info(plunit(no_tests))
 1311    ;   Failed+FailedAssertion+Blocked+STO =:= 0
 1312    ->  report_fixme,
 1313        info(plunit(all_passed(Passed)))
 1314    ;   report_blocked,
 1315        report_fixme,
 1316        report_failed_assertions,
 1317        report_failed,
 1318        report_sto,
 1319        info(plunit(passed(Passed)))
 1320    ).
 1321
 1322number_of_clauses(F/A,N) :-
 1323    (   current_predicate(F/A)
 1324    ->  functor(G,F,A),
 1325        findall(t, G, Ts),
 1326        length(Ts, N)
 1327    ;   N = 0
 1328    ).
 1329
 1330report_blocked :-
 1331    number_of_clauses(blocked/4,N),
 1332    N > 0,
 1333    !,
 1334    info(plunit(blocked(N))),
 1335    (   blocked(Unit, Name, Line, Reason),
 1336        unit_file(Unit, File),
 1337        print_message(informational,
 1338                      plunit(blocked(File:Line, Name, Reason))),
 1339        fail ; true
 1340    ).
 1341report_blocked.
 1342
 1343report_failed :-
 1344    number_of_clauses(failed/4, N),
 1345    info(plunit(failed(N))).
 1346
 1347report_failed_assertions :-
 1348    number_of_clauses(failed_assertion/7, N),
 1349    info(plunit(failed_assertions(N))).
 1350
 1351report_sto :-
 1352    number_of_clauses(sto/4, N),
 1353    info(plunit(sto(N))).
 1354
 1355report_fixme :-
 1356    report_fixme(_,_,_).
 1357
 1358report_fixme(TuplesF, TuplesP, TuplesN) :-
 1359    fixme(failed, TuplesF, Failed),
 1360    fixme(passed, TuplesP, Passed),
 1361    fixme(nondet, TuplesN, Nondet),
 1362    print_message(informational, plunit(fixme(Failed, Passed, Nondet))).
 1363
 1364
 1365fixme(How, Tuples, Count) :-
 1366    findall(fixme(Unit, Name, Line, Reason, How),
 1367            fixme(Unit, Name, Line, Reason, How), Tuples),
 1368    length(Tuples, Count).
 1369
 1370
 1371report_failure(Unit, Name, _, assertion, _) :-
 1372    !,
 1373    progress(Unit, Name, assertion).
 1374report_failure(Unit, Name, Line, Error, _Options) :-
 1375    print_message(error, plunit(failed(Unit, Name, Line, Error))).
 1376
 1377
 1378%!  test_report(What) is det.
 1379%
 1380%   Produce reports on test results after the run.
 1381
 1382test_report(fixme) :-
 1383    !,
 1384    report_fixme(TuplesF, TuplesP, TuplesN),
 1385    append([TuplesF, TuplesP, TuplesN], Tuples),
 1386    print_message(informational, plunit(fixme(Tuples))).
 1387test_report(What) :-
 1388    throw_error(domain_error(report_class, What), _).
 1389
 1390
 1391                 /*******************************
 1392                 *             INFO             *
 1393                 *******************************/
 1394
 1395%!  current_test_set(?Unit) is nondet.
 1396%
 1397%   True if Unit is a currently loaded test-set.
 1398
 1399current_test_set(Unit) :-
 1400    current_unit(Unit, _Module, _Context, _Options).
 1401
 1402%!  unit_file(+Unit, -File) is det.
 1403%!  unit_file(-Unit, +File) is nondet.
 1404
 1405unit_file(Unit, File) :-
 1406    current_unit(Unit, Module, _Context, _Options),
 1407    current_module(Module, File).
 1408unit_file(Unit, PlFile) :-
 1409    nonvar(PlFile),
 1410    test_file_for(TestFile, PlFile),
 1411    current_module(Module, TestFile),
 1412    current_unit(Unit, Module, _Context, _Options).
 1413
 1414
 1415                 /*******************************
 1416                 *             FILES            *
 1417                 *******************************/
 1418
 1419%!  load_test_files(+Options) is det.
 1420%
 1421%   Load .plt test-files related to loaded source-files.
 1422
 1423load_test_files(_Options) :-
 1424    (   source_file(File),
 1425        file_name_extension(Base, Old, File),
 1426        Old \== plt,
 1427        file_name_extension(Base, plt, TestFile),
 1428        exists_file(TestFile),
 1429        (   test_file_for(TestFile, File)
 1430        ->  true
 1431        ;   load_files(TestFile,
 1432                       [ if(changed),
 1433                         imports([])
 1434                       ]),
 1435            asserta(test_file_for(TestFile, File))
 1436        ),
 1437        fail ; true
 1438    ).
 1439
 1440
 1441
 1442                 /*******************************
 1443                 *           MESSAGES           *
 1444                 *******************************/
 1445
 1446%!  info(+Term)
 1447%
 1448%   Runs print_message(Level, Term), where Level  is one of =silent=
 1449%   or =informational= (default).
 1450
 1451info(Term) :-
 1452    message_level(Level),
 1453    print_message(Level, Term).
 1454
 1455progress(Unit, Name, Result) :-
 1456    print_message(information, plunit(progress(Unit, Name, Result))).
 1457
 1458message_level(Level) :-
 1459    current_test_flag(test_options, Options),
 1460    option(silent(Silent), Options, false),
 1461    (   Silent == false
 1462    ->  Level = informational
 1463    ;   Level = silent
 1464    ).
 1465
 1466locationprefix(File:Line) -->
 1467    !,
 1468    [ url(File:Line), ':\n\t' ].
 1469locationprefix(test(Unit,_Test,Line)) -->
 1470    !,
 1471    { unit_file(Unit, File) },
 1472    locationprefix(File:Line).
 1473locationprefix(unit(Unit)) -->
 1474    !,
 1475    [ 'PL-Unit: unit ~w: '-[Unit] ].
 1476locationprefix(FileLine) -->
 1477    { throw_error(type_error(locationprefix,FileLine), _) }.
 1478
 1479:- discontiguous
 1480    message//1. 1481:- '$hide'(message//1). 1482
 1483message(error(context_error(plunit_close(Name, -)), _)) -->
 1484    [ 'PL-Unit: cannot close unit ~w: no open unit'-[Name] ].
 1485message(error(context_error(plunit_close(Name, Start)), _)) -->
 1486    [ 'PL-Unit: cannot close unit ~w: current unit is ~w'-[Name, Start] ].
 1487message(plunit(nondet(File, Line, Name))) -->
 1488    locationprefix(File:Line),
 1489    [ 'PL-Unit: Test ~w: Test succeeded with choicepoint'- [Name] ].
 1490message(error(plunit(incompatible_options, Tests), _)) -->
 1491    [ 'PL-Unit: incompatible test-options: ~p'-[Tests] ].
 1492
 1493                                        % Unit start/end
 1494:- if(swi). 1495message(plunit(progress(_Unit, _Name, Result))) -->
 1496    [ at_same_line ], result(Result), [flush].
 1497message(plunit(begin(Unit))) -->
 1498    [ 'PL-Unit: ~w '-[Unit], flush ].
 1499message(plunit(end(_Unit))) -->
 1500    [ at_same_line, ' done' ].
 1501:- else. 1502message(plunit(begin(Unit))) -->
 1503    [ 'PL-Unit: ~w '-[Unit]/*, flush-[]*/ ].
 1504message(plunit(end(_Unit))) -->
 1505    [ ' done'-[] ].
 1506:- endif. 1507message(plunit(blocked(unit(Unit, Reason)))) -->
 1508    [ 'PL-Unit: ~w blocked: ~w'-[Unit, Reason] ].
 1509message(plunit(running([]))) -->
 1510    !,
 1511    [ 'PL-Unit: no tests running' ].
 1512message(plunit(running([One]))) -->
 1513    !,
 1514    [ 'PL-Unit: running ' ],
 1515    running(One).
 1516message(plunit(running(More))) -->
 1517    !,
 1518    [ 'PL-Unit: running tests:', nl ],
 1519    running(More).
 1520message(plunit(fixme([]))) --> !.
 1521message(plunit(fixme(Tuples))) -->
 1522    !,
 1523    fixme_message(Tuples).
 1524
 1525                                        % Blocked tests
 1526message(plunit(blocked(1))) -->
 1527    !,
 1528    [ 'one test is blocked:'-[] ].
 1529message(plunit(blocked(N))) -->
 1530    [ '~D tests are blocked:'-[N] ].
 1531message(plunit(blocked(Pos, Name, Reason))) -->
 1532    locationprefix(Pos),
 1533    test_name(Name),
 1534    [ ': ~w'-[Reason] ].
 1535
 1536                                        % fail/success
 1537message(plunit(no_tests)) -->
 1538    !,
 1539    [ 'No tests to run' ].
 1540message(plunit(all_passed(1))) -->
 1541    !,
 1542    [ 'test passed' ].
 1543message(plunit(all_passed(Count))) -->
 1544    !,
 1545    [ 'All ~D tests passed'-[Count] ].
 1546message(plunit(passed(Count))) -->
 1547    !,
 1548    [ '~D tests passed'-[Count] ].
 1549message(plunit(failed(0))) -->
 1550    !,
 1551    [].
 1552message(plunit(failed(1))) -->
 1553    !,
 1554    [ '1 test failed'-[] ].
 1555message(plunit(failed(N))) -->
 1556    [ '~D tests failed'-[N] ].
 1557message(plunit(failed_assertions(0))) -->
 1558    !,
 1559    [].
 1560message(plunit(failed_assertions(1))) -->
 1561    !,
 1562    [ '1 assertion failed'-[] ].
 1563message(plunit(failed_assertions(N))) -->
 1564    [ '~D assertions failed'-[N] ].
 1565message(plunit(sto(0))) -->
 1566    !,
 1567    [].
 1568message(plunit(sto(N))) -->
 1569    [ '~D test results depend on unification mode'-[N] ].
 1570message(plunit(fixme(0,0,0))) -->
 1571    [].
 1572message(plunit(fixme(Failed,0,0))) -->
 1573    !,
 1574    [ 'all ~D tests flagged FIXME failed'-[Failed] ].
 1575message(plunit(fixme(Failed,Passed,0))) -->
 1576    [ 'FIXME: ~D failed; ~D passed'-[Failed, Passed] ].
 1577message(plunit(fixme(Failed,Passed,Nondet))) -->
 1578    { TotalPassed is Passed+Nondet },
 1579    [ 'FIXME: ~D failed; ~D passed; (~D nondet)'-
 1580      [Failed, TotalPassed, Nondet] ].
 1581message(plunit(failed(Unit, Name, Line, Failure))) -->
 1582    { unit_file(Unit, File) },
 1583    locationprefix(File:Line),
 1584    test_name(Name),
 1585    [': '-[] ],
 1586    failure(Failure).
 1587:- if(swi). 1588message(plunit(failed_assertion(Unit, Name, Line, AssertLoc,
 1589                                _STO, Reason, Goal))) -->
 1590    { unit_file(Unit, File) },
 1591    locationprefix(File:Line),
 1592    test_name(Name),
 1593    [ ': assertion'-[] ],
 1594    assertion_location(AssertLoc, File),
 1595    assertion_reason(Reason), ['\n\t'],
 1596    assertion_goal(Unit, Goal).
 1597
 1598assertion_location(File:Line, File) -->
 1599    [ ' at line ~w'-[Line] ].
 1600assertion_location(File:Line, _) -->
 1601    [ ' at ', url(File:Line) ].
 1602assertion_location(unknown, _) -->
 1603    [].
 1604
 1605assertion_reason(fail) -->
 1606    !,
 1607    [ ' failed'-[] ].
 1608assertion_reason(Error) -->
 1609    { message_to_string(Error, String) },
 1610    [ ' raised "~w"'-[String] ].
 1611
 1612assertion_goal(Unit, Goal) -->
 1613    { unit_module(Unit, Module),
 1614      unqualify(Goal, Module, Plain)
 1615    },
 1616    [ 'Assertion: ~p'-[Plain] ].
 1617
 1618unqualify(Var, _, Var) :-
 1619    var(Var),
 1620    !.
 1621unqualify(M:Goal, Unit, Goal) :-
 1622    nonvar(M),
 1623    unit_module(Unit, M),
 1624    !.
 1625unqualify(M:Goal, _, Goal) :-
 1626    callable(Goal),
 1627    predicate_property(M:Goal, imported_from(system)),
 1628    !.
 1629unqualify(Goal, _, Goal).
 1630
 1631result(passed)    --> ['.'-[]].
 1632result(nondet)    --> ['+'-[]].
 1633result(fixme)     --> ['!'-[]].
 1634result(failed)    --> ['-'-[]].
 1635result(assertion) --> ['A'-[]].
 1636
 1637:- endif. 1638                                        % Setup/condition errors
 1639message(plunit(error(Where, Context, Exception))) -->
 1640    locationprefix(Context),
 1641    { message_to_string(Exception, String) },
 1642    [ 'error in ~w: ~w'-[Where, String] ].
 1643
 1644                                        % STO messages
 1645message(plunit(sto(Unit, Name, Line))) -->
 1646    { unit_file(Unit, File) },
 1647       locationprefix(File:Line),
 1648       test_name(Name),
 1649       [' is subject to occurs check (STO): '-[] ].
 1650message(plunit(sto(Type, Result))) -->
 1651    sto_type(Type),
 1652    sto_result(Result).
 1653
 1654                                        % Interrupts (SWI)
 1655:- if(swi). 1656message(interrupt(begin)) -->
 1657    { thread_self(Me),
 1658      running(Unit, Test, Line, STO, Me),
 1659      !,
 1660      unit_file(Unit, File)
 1661    },
 1662    [ 'Interrupted test '-[] ],
 1663    running(running(Unit:Test, File:Line, STO, Me)),
 1664    [nl],
 1665    '$messages':prolog_message(interrupt(begin)).
 1666message(interrupt(begin)) -->
 1667    '$messages':prolog_message(interrupt(begin)).
 1668:- endif. 1669
 1670test_name(@(Name,Bindings)) -->
 1671    !,
 1672    [ 'test ~w (forall bindings = ~p)'-[Name, Bindings] ].
 1673test_name(Name) -->
 1674    !,
 1675    [ 'test ~w'-[Name] ].
 1676
 1677sto_type(sto_error_incomplete) -->
 1678    [ 'Finite trees (error checking): ' ].
 1679sto_type(rational_trees) -->
 1680    [ 'Rational trees: ' ].
 1681sto_type(finite_trees) -->
 1682    [ 'Finite trees: ' ].
 1683
 1684sto_result(success(_Unit, _Name, _Line, Det, Time)) -->
 1685    det(Det),
 1686    [ ' success in ~2f seconds'-[Time] ].
 1687sto_result(failure(_Unit, _Name, _Line, How)) -->
 1688    failure(How).
 1689
 1690det(true) -->
 1691    [ 'deterministic' ].
 1692det(false) -->
 1693    [ 'non-deterministic' ].
 1694
 1695running(running(Unit:Test, File:Line, STO, Thread)) -->
 1696    thread(Thread),
 1697    [ '~q:~q at '-[Unit, Test], url(File:Line) ],
 1698    current_sto(STO).
 1699running([H|T]) -->
 1700    ['\t'], running(H),
 1701    (   {T == []}
 1702    ->  []
 1703    ;   [nl], running(T)
 1704    ).
 1705
 1706thread(main) --> !.
 1707thread(Other) -->
 1708    [' [~w] '-[Other] ].
 1709
 1710current_sto(sto_error_incomplete) -->
 1711    [ ' (STO: error checking)' ].
 1712current_sto(rational_trees) -->
 1713    [].
 1714current_sto(finite_trees) -->
 1715    [ ' (STO: occurs check enabled)' ].
 1716
 1717:- if(swi). 1718write_term(T, OPS) -->
 1719    ['~@'-[write_term(T,OPS)]].
 1720:- else. 1721write_term(T, _OPS) -->
 1722    ['~q'-[T]].
 1723:- endif. 1724
 1725expected_got_ops_(Ex, E, OPS, Goals) -->
 1726    ['    Expected: '-[]], write_term(Ex, OPS), [nl],
 1727    ['    Got:      '-[]], write_term(E,  OPS), [nl],
 1728    ( { Goals = [] } -> []
 1729    ; ['       with: '-[]], write_term(Goals, OPS), [nl]
 1730    ).
 1731
 1732
 1733failure(Var) -->
 1734    { var(Var) },
 1735    !,
 1736    [ 'Unknown failure?' ].
 1737failure(succeeded(Time)) -->
 1738    !,
 1739    [ 'must fail but succeeded in ~2f seconds~n'-[Time] ].
 1740failure(wrong_error(Expected, Error)) -->
 1741    !,
 1742    { copy_term(Expected-Error, Ex-E, Goals),
 1743      numbervars(Ex-E-Goals, 0, _),
 1744      write_options(OPS)
 1745    },
 1746    [ 'wrong error'-[], nl ],
 1747    expected_got_ops_(Ex, E, OPS, Goals).
 1748failure(wrong_answer(Cmp)) -->
 1749    { Cmp =.. [Op,Answer,Expected],
 1750      !,
 1751      copy_term(Expected-Answer, Ex-A, Goals),
 1752      numbervars(Ex-A-Goals, 0, _),
 1753      write_options(OPS)
 1754    },
 1755    [ 'wrong answer (compared using ~w)'-[Op], nl ],
 1756    expected_got_ops_(Ex, A, OPS, Goals).
 1757failure(wrong_answer(CmpExpected, Bindings)) -->
 1758    { (   CmpExpected = all(Cmp)
 1759      ->  Cmp =.. [_Op1,_,Expected],
 1760          Got = Bindings,
 1761          Type = all
 1762      ;   CmpExpected = set(Cmp),
 1763          Cmp =.. [_Op2,_,Expected0],
 1764          sort(Expected0, Expected),
 1765          sort(Bindings, Got),
 1766          Type = set
 1767      )
 1768    },
 1769    [ 'wrong "~w" answer:'-[Type] ],
 1770    [ nl, '    Expected: ~q'-[Expected] ],
 1771    [ nl, '       Found: ~q'-[Got] ].
 1772:- if(swi). 1773failure(cmp_error(_Cmp, Error)) -->
 1774    { message_to_string(Error, Message) },
 1775    [ 'Comparison error: ~w'-[Message] ].
 1776failure(Error) -->
 1777    { Error = error(_,_),
 1778      !,
 1779      message_to_string(Error, Message)
 1780    },
 1781    [ 'received error: ~w'-[Message] ].
 1782:- endif. 1783failure(Why) -->
 1784    [ '~p~n'-[Why] ].
 1785
 1786fixme_message([]) --> [].
 1787fixme_message([fixme(Unit, _Name, Line, Reason, How)|T]) -->
 1788    { unit_file(Unit, File) },
 1789    fixme_message(File:Line, Reason, How),
 1790    (   {T == []}
 1791    ->  []
 1792    ;   [nl],
 1793        fixme_message(T)
 1794    ).
 1795
 1796fixme_message(Location, Reason, failed) -->
 1797    [ 'FIXME: ~w: ~w'-[Location, Reason] ].
 1798fixme_message(Location, Reason, passed) -->
 1799    [ 'FIXME: ~w: passed ~w'-[Location, Reason] ].
 1800fixme_message(Location, Reason, nondet) -->
 1801    [ 'FIXME: ~w: passed (nondet) ~w'-[Location, Reason] ].
 1802
 1803
 1804write_options([ numbervars(true),
 1805                quoted(true),
 1806                portray(true),
 1807                max_depth(100),
 1808                attributes(portray)
 1809              ]).
 1810
 1811:- if(swi). 1812
 1813:- multifile
 1814    prolog:message/3,
 1815    user:message_hook/3. 1816
 1817prolog:message(Term) -->
 1818    message(Term).
 1819
 1820%       user:message_hook(+Term, +Kind, +Lines)
 1821
 1822user:message_hook(make(done(Files)), _, _) :-
 1823    make_run_tests(Files),
 1824    fail.                           % give other hooks a chance
 1825
 1826:- endif. 1827
 1828:- if(sicstus). 1829
 1830user:generate_message_hook(Message) -->
 1831    message(Message),
 1832    [nl].                           % SICStus requires nl at the end
 1833
 1834%!  user:message_hook(+Severity, +Message, +Lines) is semidet.
 1835%
 1836%   Redefine printing some messages. It appears   SICStus has no way
 1837%   to get multiple messages at the same   line, so we roll our own.
 1838%   As there is a lot pre-wired and   checked in the SICStus message
 1839%   handling we cannot reuse the lines. Unless I miss something ...
 1840
 1841user:message_hook(informational, plunit(begin(Unit)), _Lines) :-
 1842    format(user_error, '% PL-Unit: ~w ', [Unit]),
 1843    flush_output(user_error).
 1844user:message_hook(informational, plunit(end(_Unit)), _Lines) :-
 1845    format(user, ' done~n', []).
 1846
 1847:- endif.