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