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-2020, University of Amsterdam
    7                              VU University Amsterdam
    8                              CWI, Amsterdam
    9    All rights reserved.
   10
   11    Redistribution and use in source and binary forms, with or without
   12    modification, are permitted provided that the following conditions
   13    are met:
   14
   15    1. Redistributions of source code must retain the above copyright
   16       notice, this list of conditions and the following disclaimer.
   17
   18    2. Redistributions in binary form must reproduce the above copyright
   19       notice, this list of conditions and the following disclaimer in
   20       the documentation and/or other materials provided with the
   21       distribution.
   22
   23    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   24    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   25    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   26    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   27    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   28    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   29    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   30    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   31    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   32    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   33    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   34    POSSIBILITY OF SUCH DAMAGE.
   35*/
   36
   37:- module(plunit,
   38          [ set_test_options/1,         % +Options
   39            begin_tests/1,              % +Name
   40            begin_tests/2,              % +Name, +Options
   41            end_tests/1,                % +Name
   42            run_tests/0,                % Run all tests
   43            run_tests/1,                % Run named test-set
   44            load_test_files/1,          % +Options
   45            running_tests/0,            % Prints currently running test
   46            current_test/5,             % ?Unit,?Test,?Line,?Body,?Options
   47            test_report/1               % +What
   48          ]).   49
   50/** <module> Unit Testing
   51
   52Unit testing environment for SWI-Prolog and   SICStus Prolog. For usage,
   53please visit http://www.swi-prolog.org/pldoc/package/plunit.
   54*/
   55
   56:- autoload(library(apply), [maplist/3,include/3]).   57:- autoload(library(lists), [member/2,append/2]).   58:- autoload(library(option), [option/3,option/2]).   59:- autoload(library(ordsets), [ord_intersection/3]).   60:- autoload(library(pairs), [group_pairs_by_key/2,pairs_values/2]).   61:- autoload(library(error), [must_be/2]).   62:- autoload(library(thread), [concurrent_forall/2]).   63
   64:- meta_predicate valid_options(+, 1).   65
   66
   67                 /*******************************
   68                 *    CONDITIONAL COMPILATION   *
   69                 *******************************/
   70
   71:- discontiguous
   72    user:term_expansion/2.   73
   74:- dynamic
   75    include_code/1.   76
   77including :-
   78    include_code(X),
   79    !,
   80    X == true.
   81including.
   82
   83if_expansion((:- if(G)), []) :-
   84    (   including
   85    ->  (   catch(G, E, (print_message(error, E), fail))
   86        ->  asserta(include_code(true))
   87        ;   asserta(include_code(false))
   88        )
   89    ;   asserta(include_code(else_false))
   90    ).
   91if_expansion((:- else), []) :-
   92    (   retract(include_code(X))
   93    ->  (   X == true
   94        ->  X2 = false
   95        ;   X == false
   96        ->  X2 = true
   97        ;   X2 = X
   98        ),
   99        asserta(include_code(X2))
  100    ;   throw_error(context_error(no_if),_)
  101    ).
  102if_expansion((:- endif), []) :-
  103    retract(include_code(_)),
  104    !.
  105
  106if_expansion(_, []) :-
  107    \+ including.
  108
  109user:term_expansion(In, Out) :-
  110    prolog_load_context(module, plunit),
  111    if_expansion(In, Out).
  112
  113swi     :- catch(current_prolog_flag(dialect, swi), _, fail), !.
  114swi     :- catch(current_prolog_flag(dialect, yap), _, fail).
  115sicstus :- catch(current_prolog_flag(system_type, _), _, fail).
  116
  117
  118:- if(swi).  119throw_error(Error_term,Impldef) :-
  120    throw(error(Error_term,context(Impldef,_))).
  121
  122:- set_prolog_flag(generate_debug_info, false).  123current_test_flag(Name, Value) :-
  124    current_prolog_flag(Name, Value).
  125
  126set_test_flag(Name, Value) :-
  127    create_prolog_flag(Name, Value, []).
  128
  129% ensure expansion to avoid tracing
  130goal_expansion(forall(C,A),
  131               \+ (C, \+ A)).
  132goal_expansion(current_module(Module,File),
  133               module_property(Module, file(File))).
  134
  135:- if(current_prolog_flag(dialect, yap)).  136
  137'$set_predicate_attribute'(_, _, _).
  138
  139:- endif.  140:- endif.  141
  142:- if(sicstus).  143throw_error(Error_term,Impldef) :-
  144    throw(error(Error_term,i(Impldef))). % SICStus 3 work around
  145
  146% SWI-Compatibility
  147:- op(700, xfx, =@=).  148
  149'$set_source_module'(_, _).
  150
  151%!  current_test_flag(?Name, ?Value) is nondet.
  152%
  153%   Query  flags  that  control  the    testing   process.  Emulates
  154%   SWI-Prologs flags.
  155
  156:- dynamic test_flag/2. % Name, Val
  157
  158current_test_flag(optimise, Val) :-
  159    current_prolog_flag(compiling, Compiling),
  160    (   Compiling == debugcode ; true % TBD: Proper test
  161    ->  Val = false
  162    ;   Val = true
  163    ).
  164current_test_flag(Name, Val) :-
  165    test_flag(Name, Val).
  166
  167
  168%!  set_test_flag(+Name, +Value) is det.
  169
  170set_test_flag(Name, Val) :-
  171    var(Name),
  172    !,
  173    throw_error(instantiation_error, set_test_flag(Name,Val)).
  174set_test_flag( Name, Val ) :-
  175    retractall(test_flag(Name,_)),
  176    asserta(test_flag(Name, Val)).
  177
  178:- op(1150, fx, thread_local).  179
  180user:term_expansion((:- thread_local(PI)), (:- dynamic(PI))) :-
  181    prolog_load_context(module, plunit).
  182
  183:- endif.  184
  185                 /*******************************
  186                 *            IMPORTS           *
  187                 *******************************/
  188
  189:- initialization
  190   (   current_test_flag(test_options, _)
  191   ->  true
  192   ;   set_test_flag(test_options,
  193                 [ run(make),       % run tests on make/0
  194                   sto(false)
  195                 ])
  196   ).  197
  198%!  set_test_options(+Options)
  199%
  200%   Specifies how to deal with test suites.  Defined options are:
  201%
  202%           * load(+Load)
  203%           Whether or not the tests must be loaded.  Values are
  204%           =never=, =always=, =normal= (only if not optimised)
  205%
  206%           * run(+When)
  207%           When the tests are run.  Values are =manual=, =make=
  208%           or make(all).
  209%
  210%           * silent(+Bool)
  211%           If =true= (default =false=), report successful tests
  212%           using message level =silent=, only printing errors and
  213%           warnings.
  214%
  215%           * sto(+Bool)
  216%           How to test whether code is subject to occurs check
  217%           (STO).  If =false= (default), STO is not considered.
  218%           If =true= and supported by the hosting Prolog, code
  219%           is run in all supported unification mode and reported
  220%           if the results are inconsistent.
  221%
  222%           * cleanup(+Bool)
  223%           If =true= (default =false), cleanup report at the end
  224%           of run_tests/1.  Used to improve cooperation with
  225%           memory debuggers such as dmalloc.
  226%
  227%           * concurrent(+Bool)
  228%           If =true= (default =false), run all tests in a block
  229%           concurrently.
  230%
  231
  232set_test_options(Options) :-
  233    valid_options(Options, global_test_option),
  234    set_test_flag(test_options, Options).
  235
  236global_test_option(load(Load)) :-
  237    must_be(oneof([never,always,normal]), Load).
  238global_test_option(run(When)) :-
  239    must_be(oneof([manual,make,make(all)]), When).
  240global_test_option(silent(Bool)) :-
  241    must_be(boolean, Bool).
  242global_test_option(sto(Bool)) :-
  243    must_be(boolean, Bool).
  244global_test_option(cleanup(Bool)) :-
  245    must_be(boolean, Bool).
  246global_test_option(concurrent(Bool)) :-
  247    must_be(boolean, Bool).
  248
  249
  250%!  loading_tests
  251%
  252%   True if tests must be loaded.
  253
  254loading_tests :-
  255    current_test_flag(test_options, Options),
  256    option(load(Load), Options, normal),
  257    (   Load == always
  258    ->  true
  259    ;   Load == normal,
  260        \+ current_test_flag(optimise, true)
  261    ).
  262
  263                 /*******************************
  264                 *            MODULE            *
  265                 *******************************/
  266
  267:- dynamic
  268    loading_unit/4,                 % Unit, Module, File, OldSource
  269    current_unit/4,                 % Unit, Module, Context, Options
  270    test_file_for/2.                % ?TestFile, ?PrologFile
  271
  272%!  begin_tests(+UnitName:atom) is det.
  273%!  begin_tests(+UnitName:atom, Options) is det.
  274%
  275%   Start a test-unit. UnitName is the  name   of  the test set. the
  276%   unit is ended by :- end_tests(UnitName).
  277
  278begin_tests(Unit) :-
  279    begin_tests(Unit, []).
  280
  281begin_tests(Unit, Options) :-
  282    valid_options(Options, test_set_option),
  283    make_unit_module(Unit, Name),
  284    source_location(File, Line),
  285    begin_tests(Unit, Name, File:Line, Options).
  286
  287:- if(swi).  288begin_tests(Unit, Name, File:Line, Options) :-
  289    loading_tests,
  290    !,
  291    '$set_source_module'(Context, Context),
  292    (   current_unit(Unit, Name, Context, Options)
  293    ->  true
  294    ;   retractall(current_unit(Unit, Name, _, _)),
  295        assert(current_unit(Unit, Name, Context, Options))
  296    ),
  297    '$set_source_module'(Old, Name),
  298    '$declare_module'(Name, test, Context, File, Line, false),
  299    discontiguous(Name:'unit test'/4),
  300    '$set_predicate_attribute'(Name:'unit test'/4, trace, false),
  301    discontiguous(Name:'unit body'/2),
  302    asserta(loading_unit(Unit, Name, File, Old)).
  303begin_tests(Unit, Name, File:_Line, _Options) :-
  304    '$set_source_module'(Old, Old),
  305    asserta(loading_unit(Unit, Name, File, Old)).
  306
  307:- else.  308
  309% we cannot use discontiguous as a goal in SICStus Prolog.
  310
  311user:term_expansion((:- begin_tests(Set)),
  312                    [ (:- begin_tests(Set)),
  313                      (:- discontiguous(test/2)),
  314                      (:- discontiguous('unit body'/2)),
  315                      (:- discontiguous('unit test'/4))
  316                    ]).
  317
  318begin_tests(Unit, Name, File:_Line, Options) :-
  319    loading_tests,
  320    !,
  321    (   current_unit(Unit, Name, _, Options)
  322    ->  true
  323    ;   retractall(current_unit(Unit, Name, _, _)),
  324        assert(current_unit(Unit, Name, -, Options))
  325    ),
  326    asserta(loading_unit(Unit, Name, File, -)).
  327begin_tests(Unit, Name, File:_Line, _Options) :-
  328    asserta(loading_unit(Unit, Name, File, -)).
  329
  330:- endif.  331
  332%!  end_tests(+Name) is det.
  333%
  334%   Close a unit-test module.
  335%
  336%   @tbd    Run tests/clean module?
  337%   @tbd    End of file?
  338
  339end_tests(Unit) :-
  340    loading_unit(StartUnit, _, _, _),
  341    !,
  342    (   Unit == StartUnit
  343    ->  once(retract(loading_unit(StartUnit, _, _, Old))),
  344        '$set_source_module'(_, Old)
  345    ;   throw_error(context_error(plunit_close(Unit, StartUnit)), _)
  346    ).
  347end_tests(Unit) :-
  348    throw_error(context_error(plunit_close(Unit, -)), _).
  349
  350%!  make_unit_module(+Name, -ModuleName) is det.
  351%!  unit_module(+Name, -ModuleName) is det.
  352
  353:- if(swi).  354
  355unit_module(Unit, Module) :-
  356    atom_concat('plunit_', Unit, Module).
  357
  358make_unit_module(Unit, Module) :-
  359    unit_module(Unit, Module),
  360    (   current_module(Module),
  361        \+ current_unit(_, Module, _, _),
  362        predicate_property(Module:H, _P),
  363        \+ predicate_property(Module:H, imported_from(_M))
  364    ->  throw_error(permission_error(create, plunit, Unit),
  365                    'Existing module')
  366    ;  true
  367    ).
  368
  369:- else.  370
  371:- dynamic
  372    unit_module_store/2.  373
  374unit_module(Unit, Module) :-
  375    unit_module_store(Unit, Module),
  376    !.
  377
  378make_unit_module(Unit, Module) :-
  379    prolog_load_context(module, Module),
  380    assert(unit_module_store(Unit, Module)).
  381
  382:- endif.  383
  384                 /*******************************
  385                 *           EXPANSION          *
  386                 *******************************/
  387
  388%!  expand_test(+Name, +Options, +Body, -Clause) is det.
  389%
  390%   Expand test(Name, Options) :-  Body  into   a  clause  for
  391%   'unit test'/4 and 'unit body'/2.
  392
  393expand_test(Name, Options0, Body,
  394            [ 'unit test'(Name, Line, Options, Module:'unit body'(Id, Vars)),
  395              ('unit body'(Id, Vars) :- !, Body)
  396            ]) :-
  397    source_location(_File, Line),
  398    prolog_load_context(module, Module),
  399    atomic_list_concat([Name, '@line ', Line], Id),
  400    term_variables(Options0, OptionVars0), sort(OptionVars0, OptionVars),
  401    term_variables(Body, BodyVars0), sort(BodyVars0, BodyVars),
  402    ord_intersection(OptionVars, BodyVars, VarList),
  403    Vars =.. [vars|VarList],
  404    (   is_list(Options0)           % allow for single option without list
  405    ->  Options1 = Options0
  406    ;   Options1 = [Options0]
  407    ),
  408    maplist(expand_option, Options1, Options2),
  409    valid_options(Options2, test_option),
  410    valid_test_mode(Options2, Options).
  411
  412expand_option(Var, _) :-
  413    var(Var),
  414    !,
  415    throw_error(instantiation_error,_).
  416expand_option(A == B, true(A==B)) :- !.
  417expand_option(A = B, true(A=B)) :- !.
  418expand_option(A =@= B, true(A=@=B)) :- !.
  419expand_option(A =:= B, true(A=:=B)) :- !.
  420expand_option(error(X), throws(error(X, _))) :- !.
  421expand_option(exception(X), throws(X)) :- !. % SICStus 4 compatibility
  422expand_option(error(F,C), throws(error(F,C))) :- !. % SICStus 4 compatibility
  423expand_option(true, true(true)) :- !.
  424expand_option(O, O).
  425
  426valid_test_mode(Options0, Options) :-
  427    include(test_mode, Options0, Tests),
  428    (   Tests == []
  429    ->  Options = [true(true)|Options0]
  430    ;   Tests = [_]
  431    ->  Options = Options0
  432    ;   throw_error(plunit(incompatible_options, Tests), _)
  433    ).
  434
  435test_mode(true(_)).
  436test_mode(all(_)).
  437test_mode(set(_)).
  438test_mode(fail).
  439test_mode(throws(_)).
  440
  441
  442%!  expand(+Term, -Clauses) is semidet.
  443
  444expand(end_of_file, _) :-
  445    loading_unit(Unit, _, _, _),
  446    !,
  447    end_tests(Unit),                % warn?
  448    fail.
  449expand((:-end_tests(_)), _) :-
  450    !,
  451    fail.
  452expand(_Term, []) :-
  453    \+ loading_tests.
  454expand((test(Name) :- Body), Clauses) :-
  455    !,
  456    expand_test(Name, [], Body, Clauses).
  457expand((test(Name, Options) :- Body), Clauses) :-
  458    !,
  459    expand_test(Name, Options, Body, Clauses).
  460expand(test(Name), _) :-
  461    !,
  462    throw_error(existence_error(body, test(Name)), _).
  463expand(test(Name, _Options), _) :-
  464    !,
  465    throw_error(existence_error(body, test(Name)), _).
  466
  467:- if(swi).  468:- multifile
  469    system:term_expansion/2.  470:- endif.  471
  472system:term_expansion(Term, Expanded) :-
  473    (   loading_unit(_, _, File, _)
  474    ->  source_location(File, _),
  475        expand(Term, Expanded)
  476    ).
  477
  478
  479                 /*******************************
  480                 *             OPTIONS          *
  481                 *******************************/
  482
  483:- if(swi).  484:- else.  485must_be(list, X) :-
  486    !,
  487    (   is_list(X)
  488    ->  true
  489    ;   is_not(list, X)
  490    ).
  491must_be(Type, X) :-
  492    (   call(Type, X)
  493    ->  true
  494    ;   is_not(Type, X)
  495    ).
  496
  497is_not(Type, X) :-
  498    (   ground(X)
  499    ->  throw_error(type_error(Type, X), _)
  500    ;   throw_error(instantiation_error, _)
  501    ).
  502:- endif.  503
  504%!  valid_options(+Options, :Pred) is det.
  505%
  506%   Verify Options to be a list of valid options according to
  507%   Pred.
  508%
  509%   @throws =type_error= or =instantiation_error=.
  510
  511valid_options(Options, Pred) :-
  512    must_be(list, Options),
  513    verify_options(Options, Pred).
  514
  515verify_options([], _).
  516verify_options([H|T], Pred) :-
  517    (   call(Pred, H)
  518    ->  verify_options(T, Pred)
  519    ;   throw_error(domain_error(Pred, H), _)
  520    ).
  521
  522
  523%!  test_option(+Option) is semidet.
  524%
  525%   True if Option is a valid option for test(Name, Options).
  526
  527test_option(Option) :-
  528    test_set_option(Option),
  529    !.
  530test_option(true(_)).
  531test_option(fail).
  532test_option(throws(_)).
  533test_option(all(_)).
  534test_option(set(_)).
  535test_option(nondet).
  536test_option(fixme(_)).
  537test_option(forall(X)) :-
  538    must_be(callable, X).
  539
  540%!  test_option(+Option) is semidet.
  541%
  542%   True if Option is a valid option for :- begin_tests(Name,
  543%   Options).
  544
  545test_set_option(blocked(X)) :-
  546    must_be(ground, X).
  547test_set_option(condition(X)) :-
  548    must_be(callable, X).
  549test_set_option(setup(X)) :-
  550    must_be(callable, X).
  551test_set_option(cleanup(X)) :-
  552    must_be(callable, X).
  553test_set_option(sto(V)) :-
  554    nonvar(V), member(V, [finite_trees, rational_trees]).
  555test_set_option(concurrent(V)) :-
  556    must_be(boolean, V).
  557
  558
  559                 /*******************************
  560                 *        RUNNING TOPLEVEL      *
  561                 *******************************/
  562
  563:- thread_local
  564    passed/5,                       % Unit, Test, Line, Det, Time
  565    failed/4,                       % Unit, Test, Line, Reason
  566    failed_assertion/7,             % Unit, Test, Line, ALoc, STO, Reason, Goal
  567    blocked/4,                      % Unit, Test, Line, Reason
  568    sto/4,                          % Unit, Test, Line, Results
  569    fixme/5.                        % Unit, Test, Line, Reason, Status
  570
  571:- dynamic
  572    running/5.                      % Unit, Test, Line, STO, Thread
  573
  574%!  run_tests is semidet.
  575%!  run_tests(+TestSet) is semidet.
  576%
  577%   Run  tests  and  report  about    the   results.  The  predicate
  578%   run_tests/0 runs all known  tests  that   are  not  blocked. The
  579%   predicate run_tests/1 takes a  specification   of  tests to run.
  580%   This  is  either  a  single   specification    or   a   list  of
  581%   specifications. Each single specification is  either the name of
  582%   a test-unit or a term <test-unit>:<test>, denoting a single test
  583%   within a unit.
  584
  585run_tests :-
  586    cleanup,
  587    setup_call_cleanup(
  588        setup_trap_assertions(Ref),
  589        run_current_units,
  590        report_and_cleanup(Ref)).
  591
  592run_current_units :-
  593    forall(current_test_set(Set),
  594           run_unit(Set)),
  595    check_for_test_errors.
  596
  597report_and_cleanup(Ref) :-
  598    cleanup_trap_assertions(Ref),
  599    report,
  600    cleanup_after_test.
  601
  602run_tests(Set) :-
  603    cleanup,
  604    setup_call_cleanup(
  605        setup_trap_assertions(Ref),
  606        run_unit_and_check_errors(Set),
  607        report_and_cleanup(Ref)).
  608
  609run_unit_and_check_errors(Set) :-
  610    run_unit(Set),
  611    check_for_test_errors.
  612
  613run_unit([]) :- !.
  614run_unit([H|T]) :-
  615    !,
  616    run_unit(H),
  617    run_unit(T).
  618run_unit(Spec) :-
  619    unit_from_spec(Spec, Unit, Tests, Module, UnitOptions),
  620    (   option(blocked(Reason), UnitOptions)
  621    ->  info(plunit(blocked(unit(Unit, Reason))))
  622    ;   setup(Module, unit(Unit), UnitOptions)
  623    ->  info(plunit(begin(Spec))),
  624        current_test_flag(test_options, GlobalOptions),
  625        (   option(concurrent(true), GlobalOptions),
  626            option(concurrent(true), UnitOptions, false)
  627        ->  concurrent_forall((Module:'unit test'(Name, Line, Options, Body),
  628                               matching_test(Name, Tests)),
  629                              run_test(Unit, Name, Line, Options, Body))
  630        ;   forall((Module:'unit test'(Name, Line, Options, Body),
  631                    matching_test(Name, Tests)),
  632                   run_test(Unit, Name, Line, Options, Body))),
  633        info(plunit(end(Spec))),
  634        (   message_level(silent)
  635        ->  true
  636        ;   format(user_error, '~N', [])
  637        ),
  638        cleanup(Module, UnitOptions)
  639    ;   true
  640    ).
  641
  642unit_from_spec(Unit, Unit, _, Module, Options) :-
  643    atom(Unit),
  644    !,
  645    (   current_unit(Unit, Module, _Supers, Options)
  646    ->  true
  647    ;   throw_error(existence_error(unit_test, Unit), _)
  648    ).
  649unit_from_spec(Unit:Tests, Unit, Tests, Module, Options) :-
  650    atom(Unit),
  651    !,
  652    (   current_unit(Unit, Module, _Supers, Options)
  653    ->  true
  654    ;   throw_error(existence_error(unit_test, Unit), _)
  655    ).
  656
  657
  658matching_test(X, X) :- !.
  659matching_test(Name, Set) :-
  660    is_list(Set),
  661    memberchk(Name, Set).
  662
  663cleanup :-
  664    thread_self(Me),
  665    retractall(passed(_, _, _, _, _)),
  666    retractall(failed(_, _, _, _)),
  667    retractall(failed_assertion(_, _, _, _, _, _, _)),
  668    retractall(blocked(_, _, _, _)),
  669    retractall(sto(_, _, _, _)),
  670    retractall(fixme(_, _, _, _, _)),
  671    retractall(running(_,_,_,_,Me)).
  672
  673cleanup_after_test :-
  674    current_test_flag(test_options, Options),
  675    option(cleanup(Cleanup), Options, false),
  676    (   Cleanup == true
  677    ->  cleanup
  678    ;   true
  679    ).
  680
  681
  682%!  run_tests_in_files(+Files:list) is det.
  683%
  684%   Run all test-units that appear in the given Files.
  685
  686run_tests_in_files(Files) :-
  687    findall(Unit, unit_in_files(Files, Unit), Units),
  688    (   Units == []
  689    ->  true
  690    ;   run_tests(Units)
  691    ).
  692
  693unit_in_files(Files, Unit) :-
  694    is_list(Files),
  695    !,
  696    member(F, Files),
  697    absolute_file_name(F, Source,
  698                       [ file_type(prolog),
  699                         access(read),
  700                         file_errors(fail)
  701                       ]),
  702    unit_file(Unit, Source).
  703
  704
  705                 /*******************************
  706                 *         HOOKING MAKE/0       *
  707                 *******************************/
  708
  709%!  make_run_tests(+Files)
  710%
  711%   Called indirectly from make/0 after Files have been reloaded.
  712
  713make_run_tests(Files) :-
  714    current_test_flag(test_options, Options),
  715    option(run(When), Options, manual),
  716    (   When == make
  717    ->  run_tests_in_files(Files)
  718    ;   When == make(all)
  719    ->  run_tests
  720    ;   true
  721    ).
  722
  723:- if(swi).  724
  725unification_capability(sto_error_incomplete).
  726% can detect some (almost all) STO runs
  727unification_capability(rational_trees).
  728unification_capability(finite_trees).
  729
  730set_unification_capability(Cap) :-
  731    cap_to_flag(Cap, Flag),
  732    set_prolog_flag(occurs_check, Flag).
  733
  734current_unification_capability(Cap) :-
  735    current_prolog_flag(occurs_check, Flag),
  736    cap_to_flag(Cap, Flag),
  737    !.
  738
  739cap_to_flag(sto_error_incomplete, error).
  740cap_to_flag(rational_trees, false).
  741cap_to_flag(finite_trees, true).
  742
  743:- else.  744:- if(sicstus).  745
  746unification_capability(rational_trees).
  747set_unification_capability(rational_trees).
  748current_unification_capability(rational_trees).
  749
  750:- else.  751
  752unification_capability(_) :-
  753    fail.
  754
  755:- endif.  756:- endif.  757
  758                 /*******************************
  759                 *      ASSERTION HANDLING      *
  760                 *******************************/
  761
  762:- if(swi).  763
  764:- dynamic prolog:assertion_failed/2.  765
  766setup_trap_assertions(Ref) :-
  767    asserta((prolog:assertion_failed(Reason, Goal) :-
  768                    test_assertion_failed(Reason, Goal)),
  769            Ref).
  770
  771cleanup_trap_assertions(Ref) :-
  772    erase(Ref).
  773
  774test_assertion_failed(Reason, Goal) :-
  775    thread_self(Me),
  776    running(Unit, Test, Line, STO, Me),
  777    (   catch(get_prolog_backtrace(10, Stack), _, fail),
  778        assertion_location(Stack, AssertLoc)
  779    ->  true
  780    ;   AssertLoc = unknown
  781    ),
  782    current_test_flag(test_options, Options),
  783    report_failed_assertion(Unit, Test, Line, AssertLoc,
  784                            STO, Reason, Goal, Options),
  785    assert_cyclic(failed_assertion(Unit, Test, Line, AssertLoc,
  786                                   STO, Reason, Goal)).
  787
  788assertion_location(Stack, File:Line) :-
  789    append(_, [AssertFrame,CallerFrame|_], Stack),
  790    prolog_stack_frame_property(AssertFrame,
  791                                predicate(prolog_debug:assertion/1)),
  792    !,
  793    prolog_stack_frame_property(CallerFrame, location(File:Line)).
  794
  795report_failed_assertion(Unit, Test, Line, AssertLoc,
  796                        STO, Reason, Goal, _Options) :-
  797    print_message(
  798        error,
  799        plunit(failed_assertion(Unit, Test, Line, AssertLoc,
  800                                STO, Reason, Goal))).
  801
  802:- else.  803
  804setup_trap_assertions(_).
  805cleanup_trap_assertions(_).
  806
  807:- endif.  808
  809
  810                 /*******************************
  811                 *         RUNNING A TEST       *
  812                 *******************************/
  813
  814%!  run_test(+Unit, +Name, +Line, +Options, +Body) is det.
  815%
  816%   Run a single test.
  817
  818run_test(Unit, Name, Line, Options, Body) :-
  819    option(forall(Generator), Options),
  820    !,
  821    unit_module(Unit, Module),
  822    term_variables(Generator, Vars),
  823    forall(Module:Generator,
  824           run_test_once(Unit, @(Name,Vars), Line, Options, Body)).
  825run_test(Unit, Name, Line, Options, Body) :-
  826    run_test_once(Unit, Name, Line, Options, Body).
  827
  828run_test_once(Unit, Name, Line, Options, Body) :-
  829    current_test_flag(test_options, GlobalOptions),
  830    option(sto(false), GlobalOptions, false),
  831    !,
  832    current_unification_capability(Type),
  833    begin_test(Unit, Name, Line, Type),
  834    run_test_6(Unit, Name, Line, Options, Body, Result),
  835    end_test(Unit, Name, Line, Type),
  836    report_result(Result, Options).
  837run_test_once(Unit, Name, Line, Options, Body) :-
  838    current_unit(Unit, _Module, _Supers, UnitOptions),
  839    option(sto(Type), UnitOptions),
  840    \+ option(sto(_), Options),
  841    !,
  842    current_unification_capability(Cap0),
  843    call_cleanup(run_test_cap(Unit, Name, Line, [sto(Type)|Options], Body),
  844                 set_unification_capability(Cap0)).
  845run_test_once(Unit, Name, Line, Options, Body) :-
  846    current_unification_capability(Cap0),
  847    call_cleanup(run_test_cap(Unit, Name, Line, Options, Body),
  848                 set_unification_capability(Cap0)).
  849
  850run_test_cap(Unit, Name, Line, Options, Body) :-
  851    (   option(sto(Type), Options)
  852    ->  unification_capability(Type),
  853        set_unification_capability(Type),
  854        begin_test(Unit, Name, Line, Type),
  855        run_test_6(Unit, Name, Line, Options, Body, Result),
  856        end_test(Unit, Name, Line, Type),
  857        report_result(Result, Options)
  858    ;   findall(Key-(Type+Result),
  859                test_caps(Type, Unit, Name, Line, Options, Body, Result, Key),
  860                Pairs),
  861        group_pairs_by_key(Pairs, Keyed),
  862        (   Keyed == []
  863        ->  true
  864        ;   Keyed = [_-Results]
  865        ->  Results = [_Type+Result|_],
  866            report_result(Result, Options)          % consistent results
  867        ;   pairs_values(Pairs, ResultByType),
  868            report_result(sto(Unit, Name, Line, ResultByType), Options)
  869        )
  870    ).
  871
  872%!  test_caps(-Type, +Unit, +Name, +Line, +Options, +Body, -Result, -Key) is nondet.
  873
  874test_caps(Type, Unit, Name, Line, Options, Body, Result, Key) :-
  875    unification_capability(Type),
  876    set_unification_capability(Type),
  877    begin_test(Unit, Name, Line, Type),
  878    run_test_6(Unit, Name, Line, Options, Body, Result),
  879    end_test(Unit, Name, Line, Type),
  880    result_to_key(Result, Key),
  881    Key \== setup_failed.
  882
  883result_to_key(blocked(_, _, _, _), blocked).
  884result_to_key(failure(_, _, _, How0), failure(How1)) :-
  885    ( How0 = succeeded(_T) -> How1 = succeeded ; How0 = How1 ).
  886result_to_key(success(_, _, _, Determinism, _), success(Determinism)).
  887result_to_key(setup_failed(_,_,_), setup_failed).
  888
  889report_result(blocked(Unit, Name, Line, Reason), _) :-
  890    !,
  891    assert(blocked(Unit, Name, Line, Reason)).
  892report_result(failure(Unit, Name, Line, How), Options) :-
  893    !,
  894    failure(Unit, Name, Line, How, Options).
  895report_result(success(Unit, Name, Line, Determinism, Time), Options) :-
  896    !,
  897    success(Unit, Name, Line, Determinism, Time, Options).
  898report_result(setup_failed(_Unit, _Name, _Line), _Options).
  899report_result(sto(Unit, Name, Line, ResultByType), Options) :-
  900    assert(sto(Unit, Name, Line, ResultByType)),
  901    print_message(error, plunit(sto(Unit, Name, Line))),
  902    report_sto_results(ResultByType, Options).
  903
  904report_sto_results([], _).
  905report_sto_results([Type+Result|T], Options) :-
  906    print_message(error, plunit(sto(Type, Result))),
  907    report_sto_results(T, Options).
  908
  909
  910%!  run_test_6(+Unit, +Name, +Line, +Options, :Body, -Result) is det.
  911%
  912%   Result is one of:
  913%
  914%           * blocked(Unit, Name, Line, Reason)
  915%           * failure(Unit, Name, Line, How)
  916%           * success(Unit, Name, Line, Determinism, Time)
  917%           * setup_failed(Unit, Name, Line)
  918
  919run_test_6(Unit, Name, Line, Options, _Body,
  920           blocked(Unit, Name, Line, Reason)) :-
  921    option(blocked(Reason), Options),
  922    !.
  923run_test_6(Unit, Name, Line, Options, Body, Result) :-
  924    option(all(Answer), Options),                  % all(Bindings)
  925    !,
  926    nondet_test(all(Answer), Unit, Name, Line, Options, Body, Result).
  927run_test_6(Unit, Name, Line, Options, Body, Result) :-
  928    option(set(Answer), Options),                  % set(Bindings)
  929    !,
  930    nondet_test(set(Answer), Unit, Name, Line, Options, Body, Result).
  931run_test_6(Unit, Name, Line, Options, Body, Result) :-
  932    option(fail, Options),                         % fail
  933    !,
  934    unit_module(Unit, Module),
  935    (   setup(Module, test(Unit,Name,Line), Options)
  936    ->  statistics(runtime, [T0,_]),
  937        (   catch(Module:Body, E, true)
  938        ->  (   var(E)
  939            ->  statistics(runtime, [T1,_]),
  940                Time is (T1 - T0)/1000.0,
  941                Result = failure(Unit, Name, Line, succeeded(Time)),
  942                cleanup(Module, Options)
  943            ;   Result = failure(Unit, Name, Line, E),
  944                cleanup(Module, Options)
  945            )
  946        ;   statistics(runtime, [T1,_]),
  947            Time is (T1 - T0)/1000.0,
  948            Result = success(Unit, Name, Line, true, Time),
  949            cleanup(Module, Options)
  950        )
  951    ;   Result = setup_failed(Unit, Name, Line)
  952    ).
  953run_test_6(Unit, Name, Line, Options, Body, Result) :-
  954    option(true(Cmp), Options),
  955    !,
  956    unit_module(Unit, Module),
  957    (   setup(Module, test(Unit,Name,Line), Options) % true(Binding)
  958    ->  statistics(runtime, [T0,_]),
  959        (   catch(call_det(Module:Body, Det), E, true)
  960        ->  (   var(E)
  961            ->  statistics(runtime, [T1,_]),
  962                Time is (T1 - T0)/1000.0,
  963                (   catch(Module:Cmp, E, true)
  964                ->  (   var(E)
  965                    ->  Result = success(Unit, Name, Line, Det, Time)
  966                    ;   Result = failure(Unit, Name, Line, cmp_error(Cmp, E))
  967                    )
  968                ;   Result = failure(Unit, Name, Line, wrong_answer(Cmp))
  969                ),
  970                cleanup(Module, Options)
  971            ;   Result = failure(Unit, Name, Line, E),
  972                cleanup(Module, Options)
  973            )
  974        ;   Result = failure(Unit, Name, Line, failed),
  975            cleanup(Module, Options)
  976        )
  977    ;   Result = setup_failed(Unit, Name, Line)
  978    ).
  979run_test_6(Unit, Name, Line, Options, Body, Result) :-
  980    option(throws(Expect), Options),
  981    !,
  982    unit_module(Unit, Module),
  983    (   setup(Module, test(Unit,Name,Line), Options)
  984    ->  statistics(runtime, [T0,_]),
  985        (   catch(Module:Body, E, true)
  986        ->  (   var(E)
  987            ->  Result = failure(Unit, Name, Line, no_exception),
  988                cleanup(Module, Options)
  989            ;   statistics(runtime, [T1,_]),
  990                Time is (T1 - T0)/1000.0,
  991                (   match_error(Expect, E)
  992                ->  Result = success(Unit, Name, Line, true, Time)
  993                ;   Result = failure(Unit, Name, Line, wrong_error(Expect, E))
  994                ),
  995                cleanup(Module, Options)
  996            )
  997        ;   Result = failure(Unit, Name, Line, failed),
  998            cleanup(Module, Options)
  999        )
 1000    ;   Result = setup_failed(Unit, Name, Line)
 1001    ).
 1002
 1003
 1004%!  non_det_test(+Expected, +Unit, +Name, +Line, +Options, +Body, -Result)
 1005%
 1006%   Run tests on non-deterministic predicates.
 1007
 1008nondet_test(Expected, Unit, Name, Line, Options, Body, Result) :-
 1009    unit_module(Unit, Module),
 1010    result_vars(Expected, Vars),
 1011    statistics(runtime, [T0,_]),
 1012    (   setup(Module, test(Unit,Name,Line), Options)
 1013    ->  (   catch(findall(Vars, Module:Body, Bindings), E, true)
 1014        ->  (   var(E)
 1015            ->  statistics(runtime, [T1,_]),
 1016                Time is (T1 - T0)/1000.0,
 1017                (   nondet_compare(Expected, Bindings, Unit, Name, Line)
 1018                ->  Result = success(Unit, Name, Line, true, Time)
 1019                ;   Result = failure(Unit, Name, Line, wrong_answer(Expected, Bindings))
 1020                ),
 1021                cleanup(Module, Options)
 1022            ;   Result = failure(Unit, Name, Line, E),
 1023                cleanup(Module, Options)
 1024            )
 1025        )
 1026    ;   Result = setup_failed(Unit, Name, Line)
 1027    ).
 1028
 1029
 1030%!  result_vars(+Expected, -Vars) is det.
 1031%
 1032%   Create a term v(V1, ...) containing all variables at the left
 1033%   side of the comparison operator on Expected.
 1034
 1035result_vars(Expected, Vars) :-
 1036    arg(1, Expected, CmpOp),
 1037    arg(1, CmpOp, Vars).
 1038
 1039%!  nondet_compare(+Expected, +Bindings, +Unit, +Name, +Line) is semidet.
 1040%
 1041%   Compare list/set results for non-deterministic predicates.
 1042%
 1043%   @tbd    Properly report errors
 1044%   @bug    Sort should deal with equivalence on the comparison
 1045%           operator.
 1046
 1047nondet_compare(all(Cmp), Bindings, _Unit, _Name, _Line) :-
 1048    cmp(Cmp, _Vars, Op, Values),
 1049    cmp_list(Values, Bindings, Op).
 1050nondet_compare(set(Cmp), Bindings0, _Unit, _Name, _Line) :-
 1051    cmp(Cmp, _Vars, Op, Values0),
 1052    sort(Bindings0, Bindings),
 1053    sort(Values0, Values),
 1054    cmp_list(Values, Bindings, Op).
 1055
 1056cmp_list([], [], _Op).
 1057cmp_list([E0|ET], [V0|VT], Op) :-
 1058    call(Op, E0, V0),
 1059    cmp_list(ET, VT, Op).
 1060
 1061%!  cmp(+CmpTerm, -Left, -Op, -Right) is det.
 1062
 1063cmp(Var  == Value, Var,  ==, Value).
 1064cmp(Var =:= Value, Var, =:=, Value).
 1065cmp(Var  =  Value, Var,  =,  Value).
 1066:- if(swi). 1067cmp(Var =@= Value, Var, =@=, Value).
 1068:- else. 1069:- if(sicstus). 1070cmp(Var =@= Value, Var, variant, Value). % variant/2 is the same =@=
 1071:- endif. 1072:- endif. 1073
 1074
 1075%!  call_det(:Goal, -Det) is nondet.
 1076%
 1077%   True if Goal succeeded.  Det is unified to =true= if Goal left
 1078%   no choicepoints and =false= otherwise.
 1079
 1080:- if((swi|sicstus)). 1081call_det(Goal, Det) :-
 1082    call_cleanup(Goal,Det0=true),
 1083    ( var(Det0) -> Det = false ; Det = true ).
 1084:- else. 1085call_det(Goal, true) :-
 1086    call(Goal).
 1087:- endif. 1088
 1089%!  match_error(+Expected, +Received) is semidet.
 1090%
 1091%   True if the Received errors matches the expected error. Matching
 1092%   is based on subsumes_term/2.
 1093
 1094match_error(Expect, Rec) :-
 1095    subsumes_term(Expect, Rec).
 1096
 1097%!  setup(+Module, +Context, +Options) is semidet.
 1098%
 1099%   Call the setup handler and  fail  if   it  cannot  run  for some
 1100%   reason. The condition handler is  similar,   but  failing is not
 1101%   considered an error.  Context is one of
 1102%
 1103%       * unit(Unit)
 1104%       If it is the setup handler for a unit
 1105%       * test(Unit,Name,Line)
 1106%       If it is the setup handler for a test
 1107
 1108setup(Module, Context, Options) :-
 1109    option(condition(Condition), Options),
 1110    option(setup(Setup), Options),
 1111    !,
 1112    setup(Module, Context, [condition(Condition)]),
 1113    setup(Module, Context, [setup(Setup)]).
 1114setup(Module, Context, Options) :-
 1115    option(setup(Setup), Options),
 1116    !,
 1117    (   catch(call_ex(Module, Setup), E, true)
 1118    ->  (   var(E)
 1119        ->  true
 1120        ;   print_message(error, plunit(error(setup, Context, E))),
 1121            fail
 1122        )
 1123    ;   print_message(error, error(goal_failed(Setup), _)),
 1124        fail
 1125    ).
 1126setup(Module, Context, Options) :-
 1127    option(condition(Setup), Options),
 1128    !,
 1129    (   catch(call_ex(Module, Setup), E, true)
 1130    ->  (   var(E)
 1131        ->  true
 1132        ;   print_message(error, plunit(error(condition, Context, E))),
 1133            fail
 1134        )
 1135    ;   fail
 1136    ).
 1137setup(_,_,_).
 1138
 1139%!  call_ex(+Module, +Goal)
 1140%
 1141%   Call Goal in Module after applying goal expansion.
 1142
 1143call_ex(Module, Goal) :-
 1144    Module:(expand_goal(Goal, GoalEx),
 1145                GoalEx).
 1146
 1147%!  cleanup(+Module, +Options) is det.
 1148%
 1149%   Call the cleanup handler and succeed.   Failure  or error of the
 1150%   cleanup handler is reported, but tests continue normally.
 1151
 1152cleanup(Module, Options) :-
 1153    option(cleanup(Cleanup), Options, true),
 1154    (   catch(call_ex(Module, Cleanup), E, true)
 1155    ->  (   var(E)
 1156        ->  true
 1157        ;   print_message(warning, E)
 1158        )
 1159    ;   print_message(warning, goal_failed(Cleanup, '(cleanup handler)'))
 1160    ).
 1161
 1162success(Unit, Name, Line, Det, _Time, Options) :-
 1163    memberchk(fixme(Reason), Options),
 1164    !,
 1165    (   (   Det == true
 1166        ;   memberchk(nondet, Options)
 1167        )
 1168    ->  put_char(user_error, +),
 1169        Ok = passed
 1170    ;   put_char(user_error, !),
 1171        Ok = nondet
 1172    ),
 1173    flush_output(user_error),
 1174    assert(fixme(Unit, Name, Line, Reason, Ok)).
 1175success(Unit, Name, Line, _, _, Options) :-
 1176    failed_assertion(Unit, Name, Line, _,_,_,_),
 1177    !,
 1178    failure(Unit, Name, Line, assertion, Options).
 1179success(Unit, Name, Line, Det, Time, Options) :-
 1180    assert(passed(Unit, Name, Line, Det, Time)),
 1181    (   (   Det == true
 1182        ;   memberchk(nondet, Options)
 1183        )
 1184    ->  put_char(user_error, .)
 1185    ;   unit_file(Unit, File),
 1186        print_message(warning, plunit(nondet(File, Line, Name)))
 1187    ),
 1188    flush_output(user_error).
 1189
 1190failure(Unit, Name, Line, _, Options) :-
 1191    memberchk(fixme(Reason), Options),
 1192    !,
 1193    put_char(user_error, -),
 1194    flush_output(user_error),
 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    (   Passed+Failed+FailedAssertion+Blocked+STO =:= 0
 1300    ->  info(plunit(no_tests))
 1301    ;   Failed+FailedAssertion+Blocked+STO =:= 0
 1302    ->  report_fixme,
 1303        info(plunit(all_passed(Passed)))
 1304    ;   report_blocked,
 1305        report_fixme,
 1306        report_failed_assertions,
 1307        report_failed,
 1308        report_sto,
 1309        info(plunit(passed(Passed)))
 1310    ).
 1311
 1312number_of_clauses(F/A,N) :-
 1313    (   current_predicate(F/A)
 1314    ->  functor(G,F,A),
 1315        findall(t, G, Ts),
 1316        length(Ts, N)
 1317    ;   N = 0
 1318    ).
 1319
 1320report_blocked :-
 1321    number_of_clauses(blocked/4,N),
 1322    N > 0,
 1323    !,
 1324    info(plunit(blocked(N))),
 1325    (   blocked(Unit, Name, Line, Reason),
 1326        unit_file(Unit, File),
 1327        print_message(informational,
 1328                      plunit(blocked(File:Line, Name, Reason))),
 1329        fail ; true
 1330    ).
 1331report_blocked.
 1332
 1333report_failed :-
 1334    number_of_clauses(failed/4, N),
 1335    info(plunit(failed(N))).
 1336
 1337report_failed_assertions :-
 1338    number_of_clauses(failed_assertion/7, N),
 1339    info(plunit(failed_assertions(N))).
 1340
 1341report_sto :-
 1342    number_of_clauses(sto/4, N),
 1343    info(plunit(sto(N))).
 1344
 1345report_fixme :-
 1346    report_fixme(_,_,_).
 1347
 1348report_fixme(TuplesF, TuplesP, TuplesN) :-
 1349    fixme(failed, TuplesF, Failed),
 1350    fixme(passed, TuplesP, Passed),
 1351    fixme(nondet, TuplesN, Nondet),
 1352    print_message(informational, plunit(fixme(Failed, Passed, Nondet))).
 1353
 1354
 1355fixme(How, Tuples, Count) :-
 1356    findall(fixme(Unit, Name, Line, Reason, How),
 1357            fixme(Unit, Name, Line, Reason, How), Tuples),
 1358    length(Tuples, Count).
 1359
 1360
 1361report_failure(_, _, _, assertion, _) :-
 1362    !,
 1363    put_char(user_error, 'A').
 1364report_failure(Unit, Name, Line, Error, _Options) :-
 1365    print_message(error, plunit(failed(Unit, Name, Line, Error))).
 1366
 1367
 1368%!  test_report(What) is det.
 1369%
 1370%   Produce reports on test results after the run.
 1371
 1372test_report(fixme) :-
 1373    !,
 1374    report_fixme(TuplesF, TuplesP, TuplesN),
 1375    append([TuplesF, TuplesP, TuplesN], Tuples),
 1376    print_message(informational, plunit(fixme(Tuples))).
 1377test_report(What) :-
 1378    throw_error(domain_error(report_class, What), _).
 1379
 1380
 1381                 /*******************************
 1382                 *             INFO             *
 1383                 *******************************/
 1384
 1385%!  current_test_set(?Unit) is nondet.
 1386%
 1387%   True if Unit is a currently loaded test-set.
 1388
 1389current_test_set(Unit) :-
 1390    current_unit(Unit, _Module, _Context, _Options).
 1391
 1392%!  unit_file(+Unit, -File) is det.
 1393%!  unit_file(-Unit, +File) is nondet.
 1394
 1395unit_file(Unit, File) :-
 1396    current_unit(Unit, Module, _Context, _Options),
 1397    current_module(Module, File).
 1398unit_file(Unit, PlFile) :-
 1399    nonvar(PlFile),
 1400    test_file_for(TestFile, PlFile),
 1401    current_module(Module, TestFile),
 1402    current_unit(Unit, Module, _Context, _Options).
 1403
 1404
 1405                 /*******************************
 1406                 *             FILES            *
 1407                 *******************************/
 1408
 1409%!  load_test_files(+Options) is det.
 1410%
 1411%   Load .plt test-files related to loaded source-files.
 1412
 1413load_test_files(_Options) :-
 1414    (   source_file(File),
 1415        file_name_extension(Base, Old, File),
 1416        Old \== plt,
 1417        file_name_extension(Base, plt, TestFile),
 1418        exists_file(TestFile),
 1419        (   test_file_for(TestFile, File)
 1420        ->  true
 1421        ;   load_files(TestFile,
 1422                       [ if(changed),
 1423                         imports([])
 1424                       ]),
 1425            asserta(test_file_for(TestFile, File))
 1426        ),
 1427        fail ; true
 1428    ).
 1429
 1430
 1431
 1432                 /*******************************
 1433                 *           MESSAGES           *
 1434                 *******************************/
 1435
 1436%!  info(+Term)
 1437%
 1438%   Runs print_message(Level, Term), where Level  is one of =silent=
 1439%   or =informational= (default).
 1440
 1441info(Term) :-
 1442    message_level(Level),
 1443    print_message(Level, Term).
 1444
 1445message_level(Level) :-
 1446    current_test_flag(test_options, Options),
 1447    option(silent(Silent), Options, false),
 1448    (   Silent == false
 1449    ->  Level = informational
 1450    ;   Level = silent
 1451    ).
 1452
 1453locationprefix(File:Line) -->
 1454    !,
 1455    [ '~w:~d:\n\t'-[File,Line]].
 1456locationprefix(test(Unit,_Test,Line)) -->
 1457    !,
 1458    { unit_file(Unit, File) },
 1459    locationprefix(File:Line).
 1460locationprefix(unit(Unit)) -->
 1461    !,
 1462    [ 'PL-Unit: unit ~w: '-[Unit] ].
 1463locationprefix(FileLine) -->
 1464    { throw_error(type_error(locationprefix,FileLine), _) }.
 1465
 1466:- discontiguous
 1467    message//1. 1468
 1469message(error(context_error(plunit_close(Name, -)), _)) -->
 1470    [ 'PL-Unit: cannot close unit ~w: no open unit'-[Name] ].
 1471message(error(context_error(plunit_close(Name, Start)), _)) -->
 1472    [ 'PL-Unit: cannot close unit ~w: current unit is ~w'-[Name, Start] ].
 1473message(plunit(nondet(File, Line, Name))) -->
 1474    locationprefix(File:Line),
 1475    [ 'PL-Unit: Test ~w: Test succeeded with choicepoint'- [Name] ].
 1476message(error(plunit(incompatible_options, Tests), _)) -->
 1477    [ 'PL-Unit: incompatible test-options: ~p'-[Tests] ].
 1478
 1479                                        % Unit start/end
 1480:- if(swi). 1481message(plunit(begin(Unit))) -->
 1482    [ 'PL-Unit: ~w '-[Unit], flush ].
 1483message(plunit(end(_Unit))) -->
 1484    [ at_same_line, ' done' ].
 1485:- else. 1486message(plunit(begin(Unit))) -->
 1487    [ 'PL-Unit: ~w '-[Unit]/*, flush-[]*/ ].
 1488message(plunit(end(_Unit))) -->
 1489    [ ' done'-[] ].
 1490:- endif. 1491message(plunit(blocked(unit(Unit, Reason)))) -->
 1492    [ 'PL-Unit: ~w blocked: ~w'-[Unit, Reason] ].
 1493message(plunit(running([]))) -->
 1494    !,
 1495    [ 'PL-Unit: no tests running' ].
 1496message(plunit(running([One]))) -->
 1497    !,
 1498    [ 'PL-Unit: running ' ],
 1499    running(One).
 1500message(plunit(running(More))) -->
 1501    !,
 1502    [ 'PL-Unit: running tests:', nl ],
 1503    running(More).
 1504message(plunit(fixme([]))) --> !.
 1505message(plunit(fixme(Tuples))) -->
 1506    !,
 1507    fixme_message(Tuples).
 1508
 1509                                        % Blocked tests
 1510message(plunit(blocked(1))) -->
 1511    !,
 1512    [ 'one test is blocked:'-[] ].
 1513message(plunit(blocked(N))) -->
 1514    [ '~D tests are blocked:'-[N] ].
 1515message(plunit(blocked(Pos, Name, Reason))) -->
 1516    locationprefix(Pos),
 1517    test_name(Name),
 1518    [ ': ~w'-[Reason] ].
 1519
 1520                                        % fail/success
 1521message(plunit(no_tests)) -->
 1522    !,
 1523    [ 'No tests to run' ].
 1524message(plunit(all_passed(1))) -->
 1525    !,
 1526    [ 'test passed' ].
 1527message(plunit(all_passed(Count))) -->
 1528    !,
 1529    [ 'All ~D tests passed'-[Count] ].
 1530message(plunit(passed(Count))) -->
 1531    !,
 1532    [ '~D tests passed'-[Count] ].
 1533message(plunit(failed(0))) -->
 1534    !,
 1535    [].
 1536message(plunit(failed(1))) -->
 1537    !,
 1538    [ '1 test failed'-[] ].
 1539message(plunit(failed(N))) -->
 1540    [ '~D tests failed'-[N] ].
 1541message(plunit(failed_assertions(0))) -->
 1542    !,
 1543    [].
 1544message(plunit(failed_assertions(1))) -->
 1545    !,
 1546    [ '1 assertion failed'-[] ].
 1547message(plunit(failed_assertions(N))) -->
 1548    [ '~D assertions failed'-[N] ].
 1549message(plunit(sto(0))) -->
 1550    !,
 1551    [].
 1552message(plunit(sto(N))) -->
 1553    [ '~D test results depend on unification mode'-[N] ].
 1554message(plunit(fixme(0,0,0))) -->
 1555    [].
 1556message(plunit(fixme(Failed,0,0))) -->
 1557    !,
 1558    [ 'all ~D tests flagged FIXME failed'-[Failed] ].
 1559message(plunit(fixme(Failed,Passed,0))) -->
 1560    [ 'FIXME: ~D failed; ~D passed'-[Failed, Passed] ].
 1561message(plunit(fixme(Failed,Passed,Nondet))) -->
 1562    { TotalPassed is Passed+Nondet },
 1563    [ 'FIXME: ~D failed; ~D passed; (~D nondet)'-
 1564      [Failed, TotalPassed, Nondet] ].
 1565message(plunit(failed(Unit, Name, Line, Failure))) -->
 1566    { unit_file(Unit, File) },
 1567    locationprefix(File:Line),
 1568    test_name(Name),
 1569    [': '-[] ],
 1570    failure(Failure).
 1571:- if(swi). 1572message(plunit(failed_assertion(Unit, Name, Line, AssertLoc,
 1573                                _STO, Reason, Goal))) -->
 1574    { unit_file(Unit, File) },
 1575    locationprefix(File:Line),
 1576    test_name(Name),
 1577    [ ': assertion'-[] ],
 1578    assertion_location(AssertLoc, File),
 1579    assertion_reason(Reason), ['\n\t'],
 1580    assertion_goal(Unit, Goal).
 1581
 1582assertion_location(File:Line, File) -->
 1583    [ ' at line ~w'-[Line] ].
 1584assertion_location(File:Line, _) -->
 1585    [ ' at ~w:~w'-[File, Line] ].
 1586assertion_location(unknown, _) -->
 1587    [].
 1588
 1589assertion_reason(fail) -->
 1590    !,
 1591    [ ' failed'-[] ].
 1592assertion_reason(Error) -->
 1593    { message_to_string(Error, String) },
 1594    [ ' raised "~w"'-[String] ].
 1595
 1596assertion_goal(Unit, Goal) -->
 1597    { unit_module(Unit, Module),
 1598      unqualify(Goal, Module, Plain)
 1599    },
 1600    [ 'Assertion: ~p'-[Plain] ].
 1601
 1602unqualify(Var, _, Var) :-
 1603    var(Var),
 1604    !.
 1605unqualify(M:Goal, Unit, Goal) :-
 1606    nonvar(M),
 1607    unit_module(Unit, M),
 1608    !.
 1609unqualify(M:Goal, _, Goal) :-
 1610    callable(Goal),
 1611    predicate_property(M:Goal, imported_from(system)),
 1612    !.
 1613unqualify(Goal, _, Goal).
 1614
 1615:- endif. 1616                                        % Setup/condition errors
 1617message(plunit(error(Where, Context, Exception))) -->
 1618    locationprefix(Context),
 1619    { message_to_string(Exception, String) },
 1620    [ 'error in ~w: ~w'-[Where, String] ].
 1621
 1622                                        % STO messages
 1623message(plunit(sto(Unit, Name, Line))) -->
 1624    { unit_file(Unit, File) },
 1625       locationprefix(File:Line),
 1626       test_name(Name),
 1627       [' is subject to occurs check (STO): '-[] ].
 1628message(plunit(sto(Type, Result))) -->
 1629    sto_type(Type),
 1630    sto_result(Result).
 1631
 1632                                        % Interrupts (SWI)
 1633:- if(swi). 1634message(interrupt(begin)) -->
 1635    { thread_self(Me),
 1636      running(Unit, Test, Line, STO, Me),
 1637      !,
 1638      unit_file(Unit, File)
 1639    },
 1640    [ 'Interrupted test '-[] ],
 1641    running(running(Unit:Test, File:Line, STO, Me)),
 1642    [nl],
 1643    '$messages':prolog_message(interrupt(begin)).
 1644message(interrupt(begin)) -->
 1645    '$messages':prolog_message(interrupt(begin)).
 1646:- endif. 1647
 1648test_name(@(Name,Bindings)) -->
 1649    !,
 1650    [ 'test ~w (forall bindings = ~p)'-[Name, Bindings] ].
 1651test_name(Name) -->
 1652    !,
 1653    [ 'test ~w'-[Name] ].
 1654
 1655sto_type(sto_error_incomplete) -->
 1656    [ 'Finite trees (error checking): ' ].
 1657sto_type(rational_trees) -->
 1658    [ 'Rational trees: ' ].
 1659sto_type(finite_trees) -->
 1660    [ 'Finite trees: ' ].
 1661
 1662sto_result(success(_Unit, _Name, _Line, Det, Time)) -->
 1663    det(Det),
 1664    [ ' success in ~2f seconds'-[Time] ].
 1665sto_result(failure(_Unit, _Name, _Line, How)) -->
 1666    failure(How).
 1667
 1668det(true) -->
 1669    [ 'deterministic' ].
 1670det(false) -->
 1671    [ 'non-deterministic' ].
 1672
 1673running(running(Unit:Test, File:Line, STO, Thread)) -->
 1674    thread(Thread),
 1675    [ '~q:~q at ~w:~d'-[Unit, Test, File, Line] ],
 1676    current_sto(STO).
 1677running([H|T]) -->
 1678    ['\t'], running(H),
 1679    (   {T == []}
 1680    ->  []
 1681    ;   [nl], running(T)
 1682    ).
 1683
 1684thread(main) --> !.
 1685thread(Other) -->
 1686    [' [~w] '-[Other] ].
 1687
 1688current_sto(sto_error_incomplete) -->
 1689    [ ' (STO: error checking)' ].
 1690current_sto(rational_trees) -->
 1691    [].
 1692current_sto(finite_trees) -->
 1693    [ ' (STO: occurs check enabled)' ].
 1694
 1695:- if(swi). 1696write_term(T, OPS) -->
 1697    ['~@'-[write_term(T,OPS)]].
 1698:- else. 1699write_term(T, _OPS) -->
 1700    ['~q'-[T]].
 1701:- endif. 1702
 1703expected_got_ops_(Ex, E, OPS, Goals) -->
 1704    ['    Expected: '-[]], write_term(Ex, OPS), [nl],
 1705    ['    Got:      '-[]], write_term(E,  OPS), [nl],
 1706    ( { Goals = [] } -> []
 1707    ; ['       with: '-[]], write_term(Goals, OPS), [nl]
 1708    ).
 1709
 1710
 1711failure(Var) -->
 1712    { var(Var) },
 1713    !,
 1714    [ 'Unknown failure?' ].
 1715failure(succeeded(Time)) -->
 1716    !,
 1717    [ 'must fail but succeeded in ~2f seconds~n'-[Time] ].
 1718failure(wrong_error(Expected, Error)) -->
 1719    !,
 1720    { copy_term(Expected-Error, Ex-E, Goals),
 1721      numbervars(Ex-E-Goals, 0, _),
 1722      write_options(OPS)
 1723    },
 1724    [ 'wrong error'-[], nl ],
 1725    expected_got_ops_(Ex, E, OPS, Goals).
 1726failure(wrong_answer(Cmp)) -->
 1727    { Cmp =.. [Op,Answer,Expected],
 1728      !,
 1729      copy_term(Expected-Answer, Ex-A, Goals),
 1730      numbervars(Ex-A-Goals, 0, _),
 1731      write_options(OPS)
 1732    },
 1733    [ 'wrong answer (compared using ~w)'-[Op], nl ],
 1734    expected_got_ops_(Ex, A, OPS, Goals).
 1735failure(wrong_answer(CmpExpected, Bindings)) -->
 1736    { (   CmpExpected = all(Cmp)
 1737      ->  Cmp =.. [_Op1,_,Expected],
 1738          Got = Bindings,
 1739          Type = all
 1740      ;   CmpExpected = set(Cmp),
 1741          Cmp =.. [_Op2,_,Expected0],
 1742          sort(Expected0, Expected),
 1743          sort(Bindings, Got),
 1744          Type = set
 1745      )
 1746    },
 1747    [ 'wrong "~w" answer:'-[Type] ],
 1748    [ nl, '    Expected: ~q'-[Expected] ],
 1749    [ nl, '       Found: ~q'-[Got] ].
 1750:- if(swi). 1751failure(cmp_error(_Cmp, Error)) -->
 1752    { message_to_string(Error, Message) },
 1753    [ 'Comparison error: ~w'-[Message] ].
 1754failure(Error) -->
 1755    { Error = error(_,_),
 1756      !,
 1757      message_to_string(Error, Message)
 1758    },
 1759    [ 'received error: ~w'-[Message] ].
 1760:- endif. 1761failure(Why) -->
 1762    [ '~p~n'-[Why] ].
 1763
 1764fixme_message([]) --> [].
 1765fixme_message([fixme(Unit, _Name, Line, Reason, How)|T]) -->
 1766    { unit_file(Unit, File) },
 1767    fixme_message(File:Line, Reason, How),
 1768    (   {T == []}
 1769    ->  []
 1770    ;   [nl],
 1771        fixme_message(T)
 1772    ).
 1773
 1774fixme_message(Location, Reason, failed) -->
 1775    [ 'FIXME: ~w: ~w'-[Location, Reason] ].
 1776fixme_message(Location, Reason, passed) -->
 1777    [ 'FIXME: ~w: passed ~w'-[Location, Reason] ].
 1778fixme_message(Location, Reason, nondet) -->
 1779    [ 'FIXME: ~w: passed (nondet) ~w'-[Location, Reason] ].
 1780
 1781
 1782write_options([ numbervars(true),
 1783                quoted(true),
 1784                portray(true),
 1785                max_depth(100),
 1786                attributes(portray)
 1787              ]).
 1788
 1789:- if(swi). 1790
 1791:- multifile
 1792    prolog:message/3,
 1793    user:message_hook/3. 1794
 1795prolog:message(Term) -->
 1796    message(Term).
 1797
 1798%       user:message_hook(+Term, +Kind, +Lines)
 1799
 1800user:message_hook(make(done(Files)), _, _) :-
 1801    make_run_tests(Files),
 1802    fail.                           % give other hooks a chance
 1803
 1804:- endif. 1805
 1806:- if(sicstus). 1807
 1808user:generate_message_hook(Message) -->
 1809    message(Message),
 1810    [nl].                           % SICStus requires nl at the end
 1811
 1812%!  user:message_hook(+Severity, +Message, +Lines) is semidet.
 1813%
 1814%   Redefine printing some messages. It appears   SICStus has no way
 1815%   to get multiple messages at the same   line, so we roll our own.
 1816%   As there is a lot pre-wired and   checked in the SICStus message
 1817%   handling we cannot reuse the lines. Unless I miss something ...
 1818
 1819user:message_hook(informational, plunit(begin(Unit)), _Lines) :-
 1820    format(user_error, '% PL-Unit: ~w ', [Unit]),
 1821    flush_output(user_error).
 1822user:message_hook(informational, plunit(end(_Unit)), _Lines) :-
 1823    format(user, ' done~n', []).
 1824
 1825:- endif.