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-2023, 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,                % +Tests
   45	    run_tests/2,                % +Tests, +Options
   46	    load_test_files/1,          % +Options
   47	    running_tests/0,            % Prints currently running test
   48	    current_test/5,             % ?Unit,?Test,?Line,?Body,?Options
   49	    current_test_unit/2,        % ?Unit,?Options
   50	    test_report/1               % +What
   51	  ]).   52
   53/** <module> Unit Testing
   54
   55Unit testing environment for SWI-Prolog and   SICStus Prolog. For usage,
   56please visit https://www.swi-prolog.org/pldoc/package/plunit.
   57*/
   58
   59:- autoload(library(statistics), [call_time/2]).   60:- autoload(library(apply),
   61            [maplist/3, include/3, maplist/2, foldl/4, partition/4]).   62:- autoload(library(lists), [member/2, append/2, flatten/2, append/3]).   63:- autoload(library(option),
   64            [ option/3, option/2, merge_options/3, select_option/4,
   65              select_option/3
   66            ]).   67:- autoload(library(ordsets), [ord_intersection/3]).   68:- autoload(library(error), [must_be/2, domain_error/2]).   69:- autoload(library(thread), [concurrent_forall/2]).   70:- autoload(library(aggregate), [aggregate_all/3]).   71:- autoload(library(streams), [with_output_to/3]).   72:- autoload(library(time), [call_with_time_limit/2]).   73:- autoload(library(ansi_term), [ansi_format/3]).   74
   75:- meta_predicate
   76    valid_options(1, +),
   77    count(0, -).   78
   79		 /*******************************
   80		 *    CONDITIONAL COMPILATION   *
   81		 *******************************/
   82
   83swi     :- catch(current_prolog_flag(dialect, swi), _, fail), !.
   84swi     :- catch(current_prolog_flag(dialect, yap), _, fail).
   85sicstus :- catch(current_prolog_flag(system_type, _), _, fail).
   86
   87
   88:- if(swi).   89throw_error(Error_term,Impldef) :-
   90    throw(error(Error_term,context(Impldef,_))).
   91
   92:- set_prolog_flag(generate_debug_info, false).   93current_test_flag(Name, Value) :-
   94    current_prolog_flag(Name, Value).
   95
   96set_test_flag(Name, Value) :-
   97    create_prolog_flag(Name, Value, []).
   98
   99% ensure expansion to avoid tracing
  100goal_expansion(forall(C,A),
  101	       \+ (C, \+ A)).
  102goal_expansion(current_module(Module,File),
  103	       module_property(Module, file(File))).
  104
  105:- if(current_prolog_flag(dialect, yap)).  106
  107'$set_predicate_attribute'(_, _, _).
  108
  109:- endif.  110:- endif.  111
  112:- if(sicstus).  113throw_error(Error_term,Impldef) :-
  114    throw(error(Error_term,i(Impldef))). % SICStus 3 work around
  115
  116% SWI-Compatibility
  117:- op(700, xfx, =@=).  118
  119'$set_source_module'(_, _).
  120
  121%!  current_test_flag(?Name, ?Value) is nondet.
  122%
  123%   Query  flags  that  control  the    testing   process.  Emulates
  124%   SWI-Prologs flags.
  125
  126:- dynamic test_flag/2. % Name, Val
  127
  128current_test_flag(optimise, Val) :-
  129    current_prolog_flag(compiling, Compiling),
  130    (   Compiling == debugcode ; true % TBD: Proper test
  131    ->  Val = false
  132    ;   Val = true
  133    ).
  134current_test_flag(Name, Val) :-
  135    test_flag(Name, Val).
  136
  137
  138%!  set_test_flag(+Name, +Value) is det.
  139
  140set_test_flag(Name, Val) :-
  141    var(Name),
  142    !,
  143    throw_error(instantiation_error, set_test_flag(Name,Val)).
  144set_test_flag( Name, Val ) :-
  145    retractall(test_flag(Name,_)),
  146    asserta(test_flag(Name, Val)).
  147
  148:- op(1150, fx, thread_local).  149
  150:- discontiguous
  151    user:term_expansion/2.  152
  153user:term_expansion((:- thread_local(PI)), (:- dynamic(PI))) :-
  154    prolog_load_context(module, plunit).
  155
  156:- endif.  157
  158		 /*******************************
  159		 *            IMPORTS           *
  160		 *******************************/
  161
  162:- initialization
  163   (   current_test_flag(test_options, _)
  164   ->  true
  165   ;   set_test_flag(test_options,
  166                     [ run(make),       % run tests on make/0
  167                       output(on_failure)
  168                     ])
  169   ).  170
  171%!  set_test_options(+Options)
  172%
  173%   Specifies how to deal with test suites.  Defined options are:
  174%
  175%    - load(+Load)
  176%      Whether or not the tests must be loaded.  Values are
  177%      `never`, `always`, `normal` (only if not optimised)
  178%
  179%    - run(+When)
  180%      When the tests are run.  Values are `manual`, `make`
  181%      or make(all).
  182%
  183%    - format(+Mode)
  184%      Currently one of `tty` or `log`.   `tty` uses terminal
  185%      control to overwrite successful tests, allowing the
  186%      user to see the currently running tests and output
  187%      from failed tests.  This is the default of the output
  188%      is a tty.  `log` prints a full log of the executed
  189%      tests and their result and is intended for non-interactive
  190%      usage.
  191%
  192%    - output(+When)
  193%      If `always`, emit all output as it is produced, if `never`,
  194%      suppress all output and if `on_failure`, emit the output
  195%      if the test fails.
  196%
  197%    - occurs_check(+Mode)
  198%      Defines the default for the `occurs_check` flag during
  199%      testing.
  200%
  201%    - cleanup(+Bool)
  202%      If `true` (default =false), cleanup report at the end
  203%      of run_tests/1.  Used to improve cooperation with
  204%      memory debuggers such as dmalloc.
  205%
  206%    - concurrent(+Bool)
  207%      If `true` (default `false`), run all tests in a unit
  208%      concurrently.
  209%
  210%    - jobs(Num)
  211%      Number of jobs to use for concurrent testing.  Defaults
  212%      to the number of cores.
  213%
  214%    - timeout(+Seconds)
  215%      Set timeout for each individual test.  This acts as a
  216%      default that may be overuled at the level of units or
  217%      individual tests.
  218
  219set_test_options(Options) :-
  220    select_option(sto(Mode), Options, Options1, _),
  221    (   Mode == true
  222    ->  print_message(warning, plunit(sto(true)))
  223    ;   true
  224    ),
  225    (   option(jobs(Jobs), Options1),
  226	Jobs > 1
  227    ->  merge_options([concurrent(true)], Options1, Options2)
  228    ;   Options2 = Options1
  229    ),
  230    valid_options(global_test_option, Options2),
  231    (   current_test_flag(test_options, OldOptions)
  232    ->  merge_options(Options2, OldOptions, NewOptions),
  233        set_test_flag(test_options, NewOptions)
  234    ;   set_test_flag(test_options, Options)
  235    ).
  236
  237global_test_option(load(Load)) :-
  238    must_be(oneof([never,always,normal]), Load).
  239global_test_option(output(Cond)) :-
  240    must_be(oneof([always,on_failure]), Cond).
  241global_test_option(format(Feedback)) :-
  242    must_be(oneof([tty,log]), Feedback).
  243global_test_option(run(When)) :-
  244    must_be(oneof([manual,make,make(all)]), When).
  245global_test_option(silent(Bool)) :-
  246    must_be(boolean, Bool).
  247global_test_option(occurs_check(Mode)) :-
  248    must_be(oneof([false,true,error]), Mode).
  249global_test_option(cleanup(Bool)) :-
  250    must_be(boolean, Bool).
  251global_test_option(concurrent(Bool)) :-
  252    must_be(boolean, Bool).
  253global_test_option(jobs(Count)) :-
  254    must_be(positive_integer, Count).
  255global_test_option(timeout(Number)) :-
  256    must_be(number, Number).
  257
  258%!  loading_tests
  259%
  260%   True if tests must be loaded.
  261
  262loading_tests :-
  263    current_test_flag(test_options, Options),
  264    option(load(Load), Options, normal),
  265    (   Load == always
  266    ->  true
  267    ;   Load == normal,
  268	\+ current_test_flag(optimise, true)
  269    ).
  270
  271		 /*******************************
  272		 *            MODULE            *
  273		 *******************************/
  274
  275:- dynamic
  276    loading_unit/4,                 % Unit, Module, File, OldSource
  277    current_unit/4,                 % Unit, Module, Context, Options
  278    test_file_for/2.                % ?TestFile, ?PrologFile
  279
  280%!  begin_tests(+UnitName:atom) is det.
  281%!  begin_tests(+UnitName:atom, Options) is det.
  282%
  283%   Start a test-unit. UnitName is the  name   of  the test set. the
  284%   unit is ended by :- end_tests(UnitName).
  285
  286begin_tests(Unit) :-
  287    begin_tests(Unit, []).
  288
  289begin_tests(Unit, Options) :-
  290    must_be(atom, Unit),
  291    map_sto_option(Options, Options1),
  292    valid_options(test_set_option, Options1),
  293    make_unit_module(Unit, Name),
  294    source_location(File, Line),
  295    begin_tests(Unit, Name, File:Line, Options1).
  296
  297map_sto_option(Options0, Options) :-
  298    select_option(sto(Mode), Options0, Options1),
  299    !,
  300    map_sto(Mode, Flag),
  301    Options = [occurs_check(Flag)|Options1].
  302map_sto_option(Options, Options).
  303
  304map_sto(rational_trees, Flag) => Flag = false.
  305map_sto(finite_trees, Flag)   => Flag = true.
  306map_sto(Mode, _) => domain_error(sto, Mode).
  307
  308
  309:- if(swi).  310begin_tests(Unit, Name, File:Line, Options) :-
  311    loading_tests,
  312    !,
  313    '$set_source_module'(Context, Context),
  314    (   current_unit(Unit, Name, Context, Options)
  315    ->  true
  316    ;   retractall(current_unit(Unit, Name, _, _)),
  317	assert(current_unit(Unit, Name, Context, Options))
  318    ),
  319    '$set_source_module'(Old, Name),
  320    '$declare_module'(Name, test, Context, File, Line, false),
  321    discontiguous(Name:'unit test'/4),
  322    '$set_predicate_attribute'(Name:'unit test'/4, trace, false),
  323    discontiguous(Name:'unit body'/2),
  324    asserta(loading_unit(Unit, Name, File, Old)).
  325begin_tests(Unit, Name, File:_Line, _Options) :-
  326    '$set_source_module'(Old, Old),
  327    asserta(loading_unit(Unit, Name, File, Old)).
  328
  329:- else.  330
  331% we cannot use discontiguous as a goal in SICStus Prolog.
  332
  333user:term_expansion((:- begin_tests(Set)),
  334		    [ (:- begin_tests(Set)),
  335		      (:- discontiguous(test/2)),
  336		      (:- discontiguous('unit body'/2)),
  337		      (:- discontiguous('unit test'/4))
  338		    ]).
  339
  340begin_tests(Unit, Name, File:_Line, Options) :-
  341    loading_tests,
  342    !,
  343    (   current_unit(Unit, Name, _, Options)
  344    ->  true
  345    ;   retractall(current_unit(Unit, Name, _, _)),
  346	assert(current_unit(Unit, Name, -, Options))
  347    ),
  348    asserta(loading_unit(Unit, Name, File, -)).
  349begin_tests(Unit, Name, File:_Line, _Options) :-
  350    asserta(loading_unit(Unit, Name, File, -)).
  351
  352:- endif.  353
  354%!  end_tests(+Name) is det.
  355%
  356%   Close a unit-test module.
  357%
  358%   @tbd    Run tests/clean module?
  359%   @tbd    End of file?
  360
  361end_tests(Unit) :-
  362    loading_unit(StartUnit, _, _, _),
  363    !,
  364    (   Unit == StartUnit
  365    ->  once(retract(loading_unit(StartUnit, _, _, Old))),
  366	'$set_source_module'(_, Old)
  367    ;   throw_error(context_error(plunit_close(Unit, StartUnit)), _)
  368    ).
  369end_tests(Unit) :-
  370    throw_error(context_error(plunit_close(Unit, -)), _).
  371
  372%!  make_unit_module(+Name, -ModuleName) is det.
  373%!  unit_module(+Name, -ModuleName) is det.
  374
  375:- if(swi).  376
  377unit_module(Unit, Module) :-
  378    atom_concat('plunit_', Unit, Module).
  379
  380make_unit_module(Unit, Module) :-
  381    unit_module(Unit, Module),
  382    (   current_module(Module),
  383	\+ current_unit(_, Module, _, _),
  384	predicate_property(Module:H, _P),
  385	\+ predicate_property(Module:H, imported_from(_M))
  386    ->  throw_error(permission_error(create, plunit, Unit),
  387		    'Existing module')
  388    ;  true
  389    ).
  390
  391:- else.  392
  393:- dynamic
  394    unit_module_store/2.  395
  396unit_module(Unit, Module) :-
  397    unit_module_store(Unit, Module),
  398    !.
  399
  400make_unit_module(Unit, Module) :-
  401    prolog_load_context(module, Module),
  402    assert(unit_module_store(Unit, Module)).
  403
  404:- endif.  405
  406		 /*******************************
  407		 *           EXPANSION          *
  408		 *******************************/
  409
  410%!  expand_test(+Name, +Options, +Body, -Clause) is det.
  411%
  412%   Expand test(Name, Options) :-  Body  into   a  clause  for
  413%   'unit test'/4 and 'unit body'/2.
  414
  415expand_test(Name, Options0, Body,
  416	    [ 'unit test'(Name, Line, Options, Module:'unit body'(Id, Vars)),
  417	      ('unit body'(Id, Vars) :- !, Body)
  418	    ]) :-
  419    source_location(_File, Line),
  420    prolog_load_context(module, Module),
  421    (   prolog_load_context(variable_names, Bindings)
  422    ->  true
  423    ;   Bindings = []
  424    ),
  425    atomic_list_concat([Name, '@line ', Line], Id),
  426    term_variables(Options0, OptionVars0), sort(OptionVars0, OptionVars),
  427    term_variables(Body, BodyVars0), sort(BodyVars0, BodyVars),
  428    ord_intersection(OptionVars, BodyVars, VarList),
  429    Vars =.. [vars|VarList],
  430    (   is_list(Options0)           % allow for single option without list
  431    ->  Options1 = Options0
  432    ;   Options1 = [Options0]
  433    ),
  434    maplist(expand_option(Bindings), Options1, Options2),
  435    join_true_options(Options2, Options3),
  436    map_sto_option(Options3, Options4),
  437    valid_options(test_option, Options4),
  438    valid_test_mode(Options4, Options).
  439
  440expand_option(_, Var, _) :-
  441    var(Var),
  442    !,
  443    throw_error(instantiation_error,_).
  444expand_option(Bindings, Cmp, true(Cond)) :-
  445    cmp(Cmp),
  446    !,
  447    var_cmp(Bindings, Cmp, Cond).
  448expand_option(_, error(X), throws(error(X, _))) :- !.
  449expand_option(_, exception(X), throws(X)) :- !. % SICStus 4 compatibility
  450expand_option(_, error(F,C), throws(error(F,C))) :- !. % SICStus 4 compatibility
  451expand_option(_, true, true(true)) :- !.
  452expand_option(_, O, O).
  453
  454cmp(_ == _).
  455cmp(_ = _).
  456cmp(_ =@= _).
  457cmp(_ =:= _).
  458
  459var_cmp(Bindings, Expr, cmp(Name, Expr)) :-
  460    arg(_, Expr, Var),
  461    var(Var),
  462    member(Name=V, Bindings),
  463    V == Var,
  464    !.
  465var_cmp(_, Expr, Expr).
  466
  467join_true_options(Options0, Options) :-
  468    partition(true_option, Options0, True, Rest),
  469    True \== [],
  470    !,
  471    maplist(arg(1), True, Conds0),
  472    flatten(Conds0, Conds),
  473    Options = [true(Conds)|Rest].
  474join_true_options(Options, Options).
  475
  476true_option(true(_)).
  477
  478valid_test_mode(Options0, Options) :-
  479    include(test_mode, Options0, Tests),
  480    (   Tests == []
  481    ->  Options = [true([true])|Options0]
  482    ;   Tests = [_]
  483    ->  Options = Options0
  484    ;   throw_error(plunit(incompatible_options, Tests), _)
  485    ).
  486
  487test_mode(true(_)).
  488test_mode(all(_)).
  489test_mode(set(_)).
  490test_mode(fail).
  491test_mode(throws(_)).
  492
  493
  494%!  expand(+Term, -Clauses) is semidet.
  495
  496expand(end_of_file, _) :-
  497    loading_unit(Unit, _, _, _),
  498    !,
  499    end_tests(Unit),                % warn?
  500    fail.
  501expand((:-end_tests(_)), _) :-
  502    !,
  503    fail.
  504expand(_Term, []) :-
  505    \+ loading_tests.
  506expand((test(Name) :- Body), Clauses) :-
  507    !,
  508    expand_test(Name, [], Body, Clauses).
  509expand((test(Name, Options) :- Body), Clauses) :-
  510    !,
  511    expand_test(Name, Options, Body, Clauses).
  512expand(test(Name), _) :-
  513    !,
  514    throw_error(existence_error(body, test(Name)), _).
  515expand(test(Name, _Options), _) :-
  516    !,
  517    throw_error(existence_error(body, test(Name)), _).
  518
  519:- multifile
  520    system:term_expansion/2.  521
  522system:term_expansion(Term, Expanded) :-
  523    (   loading_unit(_, _, File, _)
  524    ->  source_location(ThisFile, _),
  525	(   File == ThisFile
  526	->  true
  527	;   source_file_property(ThisFile, included_in(File, _))
  528	),
  529	expand(Term, Expanded)
  530    ).
  531
  532
  533		 /*******************************
  534		 *             OPTIONS          *
  535		 *******************************/
  536
  537%!  valid_options(:Pred, +Options) is det.
  538%
  539%   Verify Options to be a list of valid options according to
  540%   Pred.
  541%
  542%   @error `type_error` or `instantiation_error`.
  543
  544valid_options(Pred, Options) :-
  545    must_be(list, Options),
  546    verify_options(Options, Pred).
  547
  548verify_options([], _).
  549verify_options([H|T], Pred) :-
  550    (   call(Pred, H)
  551    ->  verify_options(T, Pred)
  552    ;   throw_error(domain_error(Pred, H), _)
  553    ).
  554
  555valid_options(Pred, Options0, Options, Rest) :-
  556    must_be(list, Options0),
  557    partition(Pred, Options0, Options, Rest).
  558
  559%!  test_option(+Option) is semidet.
  560%
  561%   True if Option is a valid option for test(Name, Options).
  562
  563test_option(Option) :-
  564    test_set_option(Option),
  565    !.
  566test_option(true(_)).
  567test_option(fail).
  568test_option(throws(_)).
  569test_option(all(_)).
  570test_option(set(_)).
  571test_option(nondet).
  572test_option(fixme(_)).
  573test_option(forall(X)) :-
  574    must_be(callable, X).
  575test_option(timeout(Seconds)) :-
  576    must_be(number, Seconds).
  577
  578%!  test_option(+Option) is semidet.
  579%
  580%   True if Option is a valid option for :- begin_tests(Name,
  581%   Options).
  582
  583test_set_option(blocked(X)) :-
  584    must_be(ground, X).
  585test_set_option(condition(X)) :-
  586    must_be(callable, X).
  587test_set_option(setup(X)) :-
  588    must_be(callable, X).
  589test_set_option(cleanup(X)) :-
  590    must_be(callable, X).
  591test_set_option(occurs_check(V)) :-
  592    must_be(oneof([false,true,error]), V).
  593test_set_option(concurrent(V)) :-
  594    must_be(boolean, V).
  595test_set_option(timeout(Seconds)) :-
  596    must_be(number, Seconds).
  597
  598		 /*******************************
  599		 *             UTIL		*
  600		 *******************************/
  601
  602:- meta_predicate
  603       reify_tmo(0, -, +),
  604       reify(0, -),
  605       capture_output(0,-,+).  606
  607%!  reify_tmo(:Goal, -Result, +Options) is det.
  608
  609reify_tmo(Goal, Result, Options) :-
  610    option(timeout(Time), Options),
  611    !,
  612    reify(call_with_time_limit(Time, Goal), Result0),
  613    (   Result0 = throw(time_limit_exceeded)
  614    ->  Result = throw(time_limit_exceeded(Time))
  615    ;   Result = Result0
  616    ).
  617reify_tmo(Goal, Result, _Options) :-
  618    reify(Goal, Result).
  619
  620%!  reify(:Goal, -Result) is det.
  621%
  622%   Call  Goal  and  unify  Result  with   one  of  `true`,  `false`  or
  623%   `throw(E)`.
  624
  625reify(Goal, Result) :-
  626    (   catch(Goal, E, true)
  627    ->  (   var(E)
  628	->  Result = true
  629	;   Result = throw(E)
  630	)
  631    ;   Result = false
  632    ).
  633
  634capture_output(Goal, Output, Options) :-
  635    option(output(How), Options, always),
  636    (   How == always
  637    ->  call(Goal)
  638    ;   with_output_to(string(Output), Goal,
  639                       [ capture([user_output, user_error]),
  640                         color(true)
  641                       ])
  642    ).
  643
  644
  645		 /*******************************
  646		 *        RUNNING TOPLEVEL      *
  647		 *******************************/
  648
  649:- dynamic
  650    test_count/1,                   % Count
  651    passed/5,                       % Unit, Test, Line, Det, Time
  652    failed/5,                       % Unit, Test, Line, Reason, Time
  653    timeout/5,                      % Unit, Test, Line, Limit, Time
  654    failed_assertion/7,             % Unit, Test, Line, ALoc, STO, Reason, Goal
  655    blocked/4,                      % Unit, Test, Line, Reason
  656    fixme/5,                        % Unit, Test, Line, Reason, Status
  657    running/5,                      % Unit, Test, Line, STO, Thread
  658    forall_failures/2.              % Nth, Failures
  659
  660%!  run_tests is semidet.
  661%!  run_tests(+TestSet) is semidet.
  662%!  run_tests(+TestSet, +Options) is semidet.
  663%
  664%   Run tests and report about the   results.  The predicate run_tests/0
  665%   runs all known tests that are not blocked. The predicate run_tests/1
  666%   takes a specification of tests  to  run.
  667%
  668%   The predicate run_tests/2 is  synchronized. Concurrent testing may
  669%   be     achieved    using     the     relevant    options.      See
  670%   set_test_options/1. Options are  passed to set_test_options/1.  In
  671%   addition the following options are processed:
  672%
  673%     - summary(-Summary)
  674%       Unify Summary do a dict holding the keys below.  The value of
  675%       these keys is an integer describing the number of tests.  If
  676%       this option is given, run_tests/2 does not fail if some tests
  677%       failed.
  678%
  679%       - total
  680%       - passed
  681%       - failed
  682%       - timeout
  683%       - blocked
  684%
  685%   @arg  TestSet  is either  a  single  specification  or a  list  of
  686%   specifications. Each single specification is  either the name of a
  687%   test-unit  or a  term <test-unit>:<test>,  denoting a  single test
  688%   within a unit.  If TestSet is `all`, all known tests are executed.
  689
  690run_tests :-
  691    run_tests(all).
  692
  693run_tests(Set) :-
  694    run_tests(Set, []).
  695
  696run_tests(all, Options) :-
  697    !,
  698    findall(Unit, current_test_unit(Unit,_), Units),
  699    run_tests(Units, Options).
  700run_tests(Set, Options) :-
  701    valid_options(global_test_option, Options, Global, Rest),
  702    current_test_flag(test_options, Old),
  703    setup_call_cleanup(
  704	set_test_options(Global),
  705	( flatten([Set], List),
  706	  maplist(runnable_tests, List, Units),
  707	  with_mutex(plunit, run_tests_sync(Units, Rest))
  708	),
  709	set_test_flag(test_options, Old)).
  710
  711run_tests_sync(Units, Options) :-
  712    cleanup,
  713    count_tests(Units, Count),
  714    asserta(test_count(Count)),
  715    setup_call_cleanup(
  716	setup_jobs(Count),
  717	setup_call_cleanup(
  718	    setup_trap_assertions(Ref),
  719	    run_units_and_check_errors(Units, Options),
  720	    report_and_cleanup(Ref, Options)),
  721	cleanup_jobs).
  722
  723%!  report_and_cleanup(+Ref, +Options)
  724%
  725%   Undo changes to the environment   (trapping  assertions), report the
  726%   results and cleanup.
  727
  728report_and_cleanup(Ref, _Options) :-
  729    cleanup_trap_assertions(Ref),
  730    report,
  731    cleanup_after_test.
  732
  733%!  run_units_and_check_errors(+Units, +Options) is semidet.
  734%
  735%   Run all test units and succeed if all tests passed.
  736
  737run_units_and_check_errors(Units, Options) :-
  738    maplist(schedule_unit, Units),
  739    job_wait,
  740    test_summary(_All, Summary),
  741    (   option(summary(Summary), Options)
  742    ->  true
  743    ;   test_summary_passed(Summary)
  744    ).
  745
  746%!  runnable_tests(+Spec, -Plan) is det.
  747%
  748%   Change a Unit+Test spec  into  a   plain  `Unit:Tests`  lists, where
  749%   blocked tests or tests whose condition   fails  are already removed.
  750%   Each test in `Tests` is a  term   `@(Test,Line)`,  which serves as a
  751%   unique identifier of the test.
  752
  753:- det(runnable_tests/2).  754runnable_tests(Spec, Unit:RunnableTests) :-
  755    unit_from_spec(Spec, Unit, Tests, Module, UnitOptions),
  756    (   option(blocked(Reason), UnitOptions)
  757    ->  info(plunit(blocked(unit(Unit, Reason)))),
  758        RunnableTests = []
  759    ;   \+ condition(Module, unit(Unit), UnitOptions)
  760    ->  RunnableTests = []
  761    ;   var(Tests)
  762    ->  findall(TestID,
  763                runnable_test(Unit, _Test, Module, TestID),
  764                RunnableTests)
  765    ;   flatten([Tests], TestList),
  766        findall(TestID,
  767                ( member(Test, TestList),
  768                  runnable_test(Unit,Test,Module, TestID)
  769                ),
  770                RunnableTests)
  771    ).
  772
  773runnable_test(Unit, Test, Module, @(Test,Line)) :-
  774    current_test(Unit, Test, Line, _Body, TestOptions),
  775    (   option(blocked(Reason), TestOptions)
  776    ->  assert(blocked(Unit, Test, Line, Reason)),
  777        fail
  778    ;   condition(Module, test(Unit,Test,Line), TestOptions)
  779    ).
  780
  781unit_from_spec(Unit0:Tests0, Unit, Tests, Module, Options), atom(Unit0) =>
  782    Unit = Unit0,
  783    Tests = Tests0,
  784    (   current_unit(Unit, Module, _Supers, Options)
  785    ->  true
  786    ;   throw_error(existence_error(unit_test, Unit), _)
  787    ).
  788unit_from_spec(Unit0, Unit, _, Module, Options), atom(Unit0) =>
  789    Unit = Unit0,
  790    (   current_unit(Unit, Module, _Supers, Options)
  791    ->  true
  792    ;   throw_error(existence_error(unit_test, Unit), _)
  793    ).
  794
  795%!  count_tests(+Units, -Count) is det.
  796%
  797%   Count the number of tests to   run. A forall(Generator, Test) counts
  798%   as a single test. During the execution,   the  concrete tests of the
  799%   _forall_ are considered "sub tests".
  800
  801count_tests(Units, Count) :-
  802    foldl(count_tests_in_unit, Units, 0, Count).
  803
  804count_tests_in_unit(_Unit:Tests, Count0, Count) :-
  805    length(Tests, N),
  806    Count is Count0+N.
  807
  808%!  run_unit(+Unit) is det.
  809%
  810%   Run a single test unit. Unit is a  term Unit:Tests, where Tests is a
  811%   list of tests to run.
  812
  813run_unit(_Unit:[]) =>
  814    true.
  815run_unit(Unit:Tests) =>
  816    unit_module(Unit, Module),
  817    unit_options(Unit, UnitOptions),
  818    (   setup(Module, unit(Unit), UnitOptions)
  819    ->  begin_unit(Unit),
  820        call_time(run_unit_2(Unit, Tests), Time),
  821        test_summary(Unit, Summary),
  822	end_unit(Unit, Summary.put(time, Time)),
  823        cleanup(Module, UnitOptions)
  824    ;   job_info(end(unit(Unit, _{error:setup_failed})))
  825    ).
  826
  827begin_unit(Unit) :-
  828    job_info(begin(unit(Unit))),
  829    job_feedback(informational, begin(Unit)).
  830
  831end_unit(Unit, Summary) :-
  832    job_info(end(unit(Unit, Summary))),
  833    job_feedback(informational, end(Unit, Summary)).
  834
  835:- if(current_prolog_flag(threads, true)).  836run_unit_2(Unit, Tests) :-
  837    unit_options(Unit, UnitOptions),
  838    option(concurrent(true), UnitOptions, false),
  839    current_test_flag(test_options, GlobalOptions),
  840    option(concurrent(true), GlobalOptions),
  841    !,
  842    concurrent_forall(member(Test, Tests),
  843                      run_test(Unit, Test)).
  844:- endif.  845run_unit_2(Unit, Tests) :-
  846    forall(member(Test, Tests),
  847	   run_test(Unit, Test)).
  848
  849
  850unit_options(Unit, Options) :-
  851    current_unit(Unit, _Module, _Supers, Options).
  852
  853
  854cleanup :-
  855    set_flag(plunit_test, 1),
  856    retractall(test_count(_)),
  857    retractall(passed(_, _, _, _, _)),
  858    retractall(failed(_, _, _, _, _)),
  859    retractall(timeout(_, _, _, _, _)),
  860    retractall(failed_assertion(_, _, _, _, _, _, _)),
  861    retractall(blocked(_, _, _, _)),
  862    retractall(fixme(_, _, _, _, _)),
  863    retractall(running(_,_,_,_,_)),
  864    retractall(forall_failures(_,_)).
  865
  866cleanup_after_test :-
  867    current_test_flag(test_options, Options),
  868    option(cleanup(Cleanup), Options, false),
  869    (   Cleanup == true
  870    ->  cleanup
  871    ;   true
  872    ).
  873
  874
  875%!  run_tests_in_files(+Files:list) is det.
  876%
  877%   Run all test-units that appear in the given Files.
  878
  879run_tests_in_files(Files) :-
  880    findall(Unit, unit_in_files(Files, Unit), Units),
  881    (   Units == []
  882    ->  true
  883    ;   run_tests(Units)
  884    ).
  885
  886unit_in_files(Files, Unit) :-
  887    is_list(Files),
  888    !,
  889    member(F, Files),
  890    absolute_file_name(F, Source,
  891		       [ file_type(prolog),
  892			 access(read),
  893			 file_errors(fail)
  894		       ]),
  895    unit_file(Unit, Source).
  896
  897
  898		 /*******************************
  899		 *         HOOKING MAKE/0       *
  900		 *******************************/
  901
  902%!  make_run_tests(+Files)
  903%
  904%   Called indirectly from make/0 after Files have been reloaded.
  905
  906make_run_tests(Files) :-
  907    current_test_flag(test_options, Options),
  908    option(run(When), Options, manual),
  909    (   When == make
  910    ->  run_tests_in_files(Files)
  911    ;   When == make(all)
  912    ->  run_tests
  913    ;   true
  914    ).
  915
  916		 /*******************************
  917		 *      ASSERTION HANDLING      *
  918		 *******************************/
  919
  920:- if(swi).  921
  922:- dynamic prolog:assertion_failed/2.  923
  924setup_trap_assertions(Ref) :-
  925    asserta((prolog:assertion_failed(Reason, Goal) :-
  926		    test_assertion_failed(Reason, Goal)),
  927	    Ref).
  928
  929cleanup_trap_assertions(Ref) :-
  930    erase(Ref).
  931
  932test_assertion_failed(Reason, Goal) :-
  933    thread_self(Me),
  934    running(Unit, Test, Line, Progress, Me),
  935    (   catch(get_prolog_backtrace(10, Stack), _, fail),
  936	assertion_location(Stack, AssertLoc)
  937    ->  true
  938    ;   AssertLoc = unknown
  939    ),
  940    current_test_flag(test_options, Options),
  941    report_failed_assertion(Unit:Test, Line, AssertLoc,
  942			    Progress, Reason, Goal, Options),
  943    assert_cyclic(failed_assertion(Unit, Test, Line, AssertLoc,
  944				   Progress, Reason, Goal)).
  945
  946assertion_location(Stack, File:Line) :-
  947    append(_, [AssertFrame,CallerFrame|_], Stack),
  948    prolog_stack_frame_property(AssertFrame,
  949				predicate(prolog_debug:assertion/1)),
  950    !,
  951    prolog_stack_frame_property(CallerFrame, location(File:Line)).
  952
  953report_failed_assertion(UnitTest, Line, AssertLoc,
  954			Progress, Reason, Goal, _Options) :-
  955    print_message(
  956	error,
  957	plunit(failed_assertion(UnitTest, Line, AssertLoc,
  958				Progress, Reason, Goal))).
  959
  960:- else.  961
  962setup_trap_assertions(_).
  963cleanup_trap_assertions(_).
  964
  965:- endif.  966
  967
  968		 /*******************************
  969		 *         RUNNING A TEST       *
  970		 *******************************/
  971
  972%!  run_test(+Unit, +Test) is det.
  973%
  974%   Run a single test.
  975
  976run_test(Unit, @(Test,Line)) :-
  977    unit_module(Unit, Module),
  978    Module:'unit test'(Test, Line, TestOptions, Body),
  979    unit_options(Unit, UnitOptions),
  980    run_test(Unit, Test, Line, UnitOptions, TestOptions, Body).
  981
  982%!  run_test(+Unit, +Name, +Line, +UnitOptions, +Options, +Body)
  983%
  984%   Deals with forall(Generator, Test)
  985
  986run_test(Unit, Name, Line, UnitOptions, Options, Body) :-
  987    option(forall(Generator), Options),
  988    !,
  989    unit_module(Unit, Module),
  990    term_variables(Generator, Vars),
  991    start_test(Unit, @(Name,Line), Nth),
  992    State = state(0),
  993    call_time(forall(Module:Generator,                      % may become concurrent
  994                     (   incr_forall(State, I),
  995                         run_test_once6(Unit, Name, forall(Vars, Nth-I), Line,
  996                                        UnitOptions, Options, Body)
  997                     )),
  998                     Time),
  999    arg(1, State, Generated),
 1000    progress(Unit:Name, Nth, forall(end, Nth, Generated), Time).
 1001run_test(Unit, Name, Line, UnitOptions, Options, Body) :-
 1002    start_test(Unit, @(Name,Line), Nth),
 1003    run_test_once6(Unit, Name, Nth, Line, UnitOptions, Options, Body).
 1004
 1005start_test(_Unit, _TestID, Nth) :-
 1006    flag(plunit_test, Nth, Nth+1).
 1007
 1008incr_forall(State, I) :-
 1009    arg(1, State, I0),
 1010    I is I0+1,
 1011    nb_setarg(1, State, I).
 1012
 1013%!  run_test_once6(+Unit, +Name, +Progress, +Line, +UnitOptions,
 1014%!                 +Options, +Body)
 1015%
 1016%   Inherit the `timeout` and `occurs_check` option (Global -> Unit -> Test).
 1017
 1018run_test_once6(Unit, Name, Progress, Line, UnitOptions, Options, Body) :-
 1019    current_test_flag(test_options, GlobalOptions),
 1020    inherit_option(timeout,      Options,  [UnitOptions, GlobalOptions], Options1),
 1021    inherit_option(occurs_check, Options1, [UnitOptions, GlobalOptions], Options2),
 1022    run_test_once(Unit, Name, Progress, Line, Options2, Body).
 1023
 1024inherit_option(Name, Options0, Chain, Options) :-
 1025    Term =.. [Name,_Value],
 1026    (   option(Term, Options0)
 1027    ->  Options = Options0
 1028    ;   member(Opts, Chain),
 1029        option(Term, Opts)
 1030    ->  Options = [Term|Options0]
 1031    ;   Options = Options0
 1032    ).
 1033
 1034%!  run_test_once(+Unit, +Name, Progress, +Line, +Options, +Body)
 1035%
 1036%   Deal with occurs_check, i.e., running the  test multiple times with different
 1037%   unification settings wrt. the occurs check.
 1038
 1039run_test_once(Unit, Name, Progress, Line, Options, Body) :-
 1040    option(occurs_check(Mode), Options),
 1041    !,
 1042    current_test_flag(test_options, GlobalOptions),
 1043    begin_test(Unit, Name, Line, Progress),
 1044    current_prolog_flag(occurs_check, Old),
 1045    setup_call_cleanup(
 1046	set_prolog_flag(occurs_check, Mode),
 1047	capture_output(run_test_6(Unit, Name, Line, Options, Body, Result),
 1048		       Output, GlobalOptions),
 1049	set_prolog_flag(occurs_check, Old)),
 1050    end_test(Unit, Name, Line, Progress),
 1051    report_result(Result, Progress, Output, Options).
 1052run_test_once(Unit, Name, Progress, Line, Options, Body) :-
 1053    current_test_flag(test_options, GlobalOptions),
 1054    begin_test(Unit, Name, Line, Progress),
 1055    capture_output(run_test_6(Unit, Name, Line, Options, Body, Result),
 1056		   Output, GlobalOptions),
 1057    end_test(Unit, Name, Line, Progress),
 1058    report_result(Result, Progress, Output, Options).
 1059
 1060%!  report_result(+Result, +Progress, +Output, +Options) is det.
 1061
 1062:- det(report_result/4). 1063report_result(failure(Unit, Name, Line, How, Time),
 1064	      Progress, Output, Options) :-
 1065    !,
 1066    failure(Unit, Name, Progress, Line, How, Time, Output, Options).
 1067report_result(success(Unit, Name, Line, Determinism, Time),
 1068	      Progress, Output, Options) :-
 1069    !,
 1070    success(Unit, Name, Progress, Line, Determinism, Time, Output, Options).
 1071report_result(setup_failed(_Unit, _Name, _Line),
 1072	      _Progress, _Output, _Options).
 1073
 1074%!  run_test_6(+Unit, +Name, +Line, +Options, :Body, -Result) is det.
 1075%
 1076%   6th step  of the  tests.  Deals  with tests  that must  be ignored
 1077%   (blocked, conditions fails), setup and cleanup at the test level.
 1078%   Result is one of:
 1079%
 1080%     - failure(Unit, Name, Line, How, Time)
 1081%       How is one of:
 1082%       - succeeded
 1083%       - Exception
 1084%       - time_limit_exceeded(Limit)
 1085%       - cmp_error(Cmp, E)
 1086%       - wrong_answer(Cmp)
 1087%       - failed
 1088%       - no_exception
 1089%       - wrong_error(Expect, E)
 1090%       - wrong_answer(Expected, Bindings)
 1091%     - success(Unit, Name, Line, Determinism, Time)
 1092%     - setup_failed(Unit, Name, Line)
 1093
 1094run_test_6(Unit, Name, Line, Options, Body, Result) :-
 1095    option(setup(_Setup), Options),
 1096    !,
 1097    (   unit_module(Unit, Module),
 1098        setup(Module, test(Unit,Name,Line), Options)
 1099    ->  run_test_7(Unit, Name, Line, Options, Body, Result),
 1100        cleanup(Module, Options)
 1101    ;   Result = setup_failed(Unit, Name, Line)
 1102    ).
 1103run_test_6(Unit, Name, Line, Options, Body, Result) :-
 1104    unit_module(Unit, Module),
 1105    run_test_7(Unit, Name, Line, Options, Body, Result),
 1106    cleanup(Module, Options).
 1107
 1108%!  run_test_7(+Unit, +Name, +Line, +Options, :Body, -Result) is det.
 1109%
 1110%   This step  deals with the expected  outcome of the test.   It runs
 1111%   the  actual test  and then  compares  the result  to the  outcome.
 1112%   There are  two main categories:  dealing with a single  result and
 1113%   all results.
 1114
 1115run_test_7(Unit, Name, Line, Options, Body, Result) :-
 1116    option(true(Cmp), Options),			   % expected success
 1117    !,
 1118    unit_module(Unit, Module),
 1119    call_time(reify_tmo(call_det(Module:Body, Det), Result0, Options), Time),
 1120    (   Result0 == true
 1121    ->  cmp_true(Cmp, Module, CmpResult),
 1122	(   CmpResult == []
 1123	->  Result = success(Unit, Name, Line, Det, Time)
 1124	;   Result = failure(Unit, Name, Line, CmpResult, Time)
 1125	)
 1126    ;   Result0 == false
 1127    ->  Result = failure(Unit, Name, Line, failed, Time)
 1128    ;   Result0 = throw(E2)
 1129    ->  Result = failure(Unit, Name, Line, throw(E2), Time)
 1130    ).
 1131run_test_7(Unit, Name, Line, Options, Body, Result) :-
 1132    option(fail, Options),                         % expected failure
 1133    !,
 1134    unit_module(Unit, Module),
 1135    call_time(reify_tmo(Module:Body, Result0, Options), Time),
 1136    (   Result0 == true
 1137    ->  Result = failure(Unit, Name, Line, succeeded, Time)
 1138    ;   Result0 == false
 1139    ->  Result = success(Unit, Name, Line, true, Time)
 1140    ;   Result0 = throw(E)
 1141    ->  Result = failure(Unit, Name, Line, throw(E), Time)
 1142    ).
 1143run_test_7(Unit, Name, Line, Options, Body, Result) :-
 1144    option(throws(Expect), Options),		   % Expected error
 1145    !,
 1146    unit_module(Unit, Module),
 1147    call_time(reify_tmo(Module:Body, Result0, Options), Time),
 1148    (   Result0 == true
 1149    ->  Result = failure(Unit, Name, Line, no_exception, Time)
 1150    ;   Result0 == false
 1151    ->  Result = failure(Unit, Name, Line, failed, Time)
 1152    ;   Result0 = throw(E)
 1153    ->  (   match_error(Expect, E)
 1154        ->  Result = success(Unit, Name, Line, true, Time)
 1155        ;   Result = failure(Unit, Name, Line, wrong_error(Expect, E), Time)
 1156        )
 1157    ).
 1158run_test_7(Unit, Name, Line, Options, Body, Result) :-
 1159    option(all(Answer), Options),                  % all(Bindings)
 1160    !,
 1161    nondet_test(all(Answer), Unit, Name, Line, Options, Body, Result).
 1162run_test_7(Unit, Name, Line, Options, Body, Result) :-
 1163    option(set(Answer), Options),                  % set(Bindings)
 1164    !,
 1165    nondet_test(set(Answer), Unit, Name, Line, Options, Body, Result).
 1166
 1167%!  non_det_test(+Expected, +Unit, +Name, +Line, +Options, +Body, -Result)
 1168%
 1169%   Run tests on non-deterministic predicates.
 1170
 1171nondet_test(Expected, Unit, Name, Line, Options, Body, Result) :-
 1172    unit_module(Unit, Module),
 1173    result_vars(Expected, Vars),
 1174    (   call_time(reify_tmo(findall(Vars, Module:Body, Bindings),
 1175                            Result0, Options), Time)
 1176    ->  (   Result0 == true
 1177        ->  (   nondet_compare(Expected, Bindings, Unit, Name, Line)
 1178            ->  Result = success(Unit, Name, Line, true, Time)
 1179            ;   Result = failure(Unit, Name, Line,
 1180				 [wrong_answer(Expected, Bindings)], Time)
 1181            )
 1182        ;   Result0 = throw(E)
 1183        ->  Result = failure(Unit, Name, Line, throw(E), Time)
 1184        )
 1185    ).
 1186
 1187cmp_true([], _, L) =>
 1188    L = [].
 1189cmp_true([Cmp|T], Module, L) =>
 1190    E = error(Formal,_),
 1191    cmp_goal(Cmp, Goal),
 1192    (   catch(Module:Goal, E, true)
 1193    ->  (   var(Formal)
 1194	->  cmp_true(T, Module, L)
 1195	;   L = [cmp_error(Cmp,E)|L1],
 1196	    cmp_true(T, Module, L1)
 1197	)
 1198    ;   L = [wrong_answer(Cmp)|L1],
 1199	cmp_true(T, Module, L1)
 1200    ).
 1201
 1202cmp_goal(cmp(_Var, Expr), Goal) => Goal = Expr.
 1203cmp_goal(Expr, Goal) => Goal = Expr.
 1204
 1205
 1206%!  result_vars(+Expected, -Vars) is det.
 1207%
 1208%   Create a term v(V1, ...) containing all variables at the left
 1209%   side of the comparison operator on Expected.
 1210
 1211result_vars(Expected, Vars) :-
 1212    arg(1, Expected, CmpOp),
 1213    arg(1, CmpOp, Vars).
 1214
 1215%!  nondet_compare(+Expected, +Bindings, +Unit, +Name, +Line) is semidet.
 1216%
 1217%   Compare list/set results for non-deterministic predicates.
 1218%
 1219%   @tbd    Properly report errors
 1220%   @bug    Sort should deal with equivalence on the comparison
 1221%           operator.
 1222
 1223nondet_compare(all(Cmp), Bindings, _Unit, _Name, _Line) :-
 1224    cmp(Cmp, _Vars, Op, Values),
 1225    cmp_list(Values, Bindings, Op).
 1226nondet_compare(set(Cmp), Bindings0, _Unit, _Name, _Line) :-
 1227    cmp(Cmp, _Vars, Op, Values0),
 1228    sort(Bindings0, Bindings),
 1229    sort(Values0, Values),
 1230    cmp_list(Values, Bindings, Op).
 1231
 1232cmp_list([], [], _Op).
 1233cmp_list([E0|ET], [V0|VT], Op) :-
 1234    call(Op, E0, V0),
 1235    cmp_list(ET, VT, Op).
 1236
 1237%!  cmp(+CmpTerm, -Left, -Op, -Right) is det.
 1238
 1239cmp(Var  == Value, Var,  ==, Value).
 1240cmp(Var =:= Value, Var, =:=, Value).
 1241cmp(Var  =  Value, Var,  =,  Value).
 1242:- if(swi). 1243cmp(Var =@= Value, Var, =@=, Value).
 1244:- else. 1245:- if(sicstus). 1246cmp(Var =@= Value, Var, variant, Value). % variant/2 is the same =@=
 1247:- endif. 1248:- endif. 1249
 1250
 1251%!  call_det(:Goal, -Det) is nondet.
 1252%
 1253%   True if Goal succeeded.  Det is unified to =true= if Goal left
 1254%   no choicepoints and =false= otherwise.
 1255
 1256:- if((swi;sicstus)). 1257call_det(Goal, Det) :-
 1258    call_cleanup(Goal,Det0=true),
 1259    ( var(Det0) -> Det = false ; Det = true ).
 1260:- else. 1261call_det(Goal, true) :-
 1262    call(Goal).
 1263:- endif. 1264
 1265%!  match_error(+Expected, +Received) is semidet.
 1266%
 1267%   True if the Received errors matches the expected error. Matching
 1268%   is based on subsumes_term/2.
 1269
 1270match_error(Expect, Rec) :-
 1271    subsumes_term(Expect, Rec).
 1272
 1273%!  setup(+Module, +Context, +Options) is semidet.
 1274%
 1275%   Call the setup handler and  fail  if   it  cannot  run  for some
 1276%   reason. The condition handler is  similar,   but  failing is not
 1277%   considered an error.  Context is one of
 1278%
 1279%    - unit(Unit)
 1280%      If it is the setup handler for a unit
 1281%    - test(Unit,Name,Line)
 1282%      If it is the setup handler for a test
 1283
 1284setup(Module, Context, Options) :-
 1285    option(setup(Setup), Options),
 1286    !,
 1287    current_test_flag(test_options, GlobalOptions),
 1288    capture_output(reify(call_ex(Module, Setup), Result),
 1289		   Output, GlobalOptions),
 1290    (   Result == true
 1291    ->  true
 1292    ;   print_message(error,
 1293		      plunit(error(setup, Context, Output, Result))),
 1294	fail
 1295    ).
 1296setup(_,_,_).
 1297
 1298%!  condition(+Module, +Context, +Options) is semidet.
 1299%
 1300%   Evaluate the test or test unit condition.
 1301
 1302condition(Module, Context, Options) :-
 1303    option(condition(Cond), Options),
 1304    !,
 1305    current_test_flag(test_options, GlobalOptions),
 1306    capture_output(reify(call_ex(Module, Cond), Result),
 1307		   Output, GlobalOptions),
 1308    (   Result == true
 1309    ->  true
 1310    ;   Result == false
 1311    ->  fail
 1312    ;   print_message(error,
 1313		      plunit(error(condition, Context, Output, Result))),
 1314	fail
 1315    ).
 1316condition(_, _, _).
 1317
 1318
 1319%!  call_ex(+Module, +Goal)
 1320%
 1321%   Call Goal in Module after applying goal expansion.
 1322
 1323call_ex(Module, Goal) :-
 1324    Module:(expand_goal(Goal, GoalEx),
 1325	    GoalEx).
 1326
 1327%!  cleanup(+Module, +Options) is det.
 1328%
 1329%   Call the cleanup handler and succeed.   Failure  or error of the
 1330%   cleanup handler is reported, but tests continue normally.
 1331
 1332cleanup(Module, Options) :-
 1333    option(cleanup(Cleanup), Options, true),
 1334    (   catch(call_ex(Module, Cleanup), E, true)
 1335    ->  (   var(E)
 1336	->  true
 1337	;   print_message(warning, E)
 1338	)
 1339    ;   print_message(warning, goal_failed(Cleanup, '(cleanup handler)'))
 1340    ).
 1341
 1342success(Unit, Name, Progress, Line, Det, Time, _Output, Options) :-
 1343    memberchk(fixme(Reason), Options),
 1344    !,
 1345    (   (   Det == true
 1346	;   memberchk(nondet, Options)
 1347	)
 1348    ->  progress(Unit:Name, Progress, fixme(passed), Time),
 1349	Ok = passed
 1350    ;   progress(Unit:Name, Progress, fixme(nondet), Time),
 1351	Ok = nondet
 1352    ),
 1353    flush_output(user_error),
 1354    assert(fixme(Unit, Name, Line, Reason, Ok)).
 1355success(Unit, Name, Progress, Line, _, Time, Output, Options) :-
 1356    failed_assertion(Unit, Name, Line, _,_,_,_),
 1357    !,
 1358    failure(Unit, Name, Progress, Line, assertion, Time, Output, Options).
 1359success(Unit, Name, Progress, Line, Det, Time, _Output, Options) :-
 1360    assert(passed(Unit, Name, Line, Det, Time)),
 1361    (   (   Det == true
 1362	;   memberchk(nondet, Options)
 1363	)
 1364    ->  progress(Unit:Name, Progress, passed, Time)
 1365    ;   unit_file(Unit, File),
 1366	print_message(warning, plunit(nondet(File, Line, Name)))
 1367    ).
 1368
 1369%!  failure(+Unit, +Name, +Progress, +Line,
 1370%!          +How, +Time, +Output, +Options) is det.
 1371%
 1372%   Test failed.  Report the error.
 1373
 1374failure(Unit, Name, Progress, Line, _, Time, _Output, Options),
 1375  memberchk(fixme(Reason), Options) =>
 1376    assert(fixme(Unit, Name, Line, Reason, failed)),
 1377    progress(Unit:Name, Progress, fixme(failed), Time).
 1378failure(Unit, Name, Progress, Line, time_limit_exceeded(Limit), Time,
 1379	Output, Options) =>
 1380    assert_cyclic(timeout(Unit, Name, Line, Limit, Time)),
 1381    progress(Unit:Name, Progress, timeout(Limit), Time),
 1382    report_failure(Unit, Name, Progress, Line, timeout(Limit), Time, Output, Options).
 1383failure(Unit, Name, Progress, Line, E, Time, Output, Options) =>
 1384    assert_cyclic(failed(Unit, Name, Line, E, Time)),
 1385    progress(Unit:Name, Progress, failed, Time),
 1386    report_failure(Unit, Name, Progress, Line, E, Time, Output, Options).
 1387
 1388%!  assert_cyclic(+Term) is det.
 1389%
 1390%   Assert  a  possibly  cyclic  unit   clause.  Current  SWI-Prolog
 1391%   assert/1 does not handle cyclic terms,  so we emulate this using
 1392%   the recorded database.
 1393%
 1394%   @tbd    Implement cycle-safe assert and remove this.
 1395
 1396:- if(swi). 1397assert_cyclic(Term) :-
 1398    acyclic_term(Term),
 1399    !,
 1400    assert(Term).
 1401assert_cyclic(Term) :-
 1402    Term =.. [Functor|Args],
 1403    recorda(cyclic, Args, Id),
 1404    functor(Term, _, Arity),
 1405    length(NewArgs, Arity),
 1406    Head =.. [Functor|NewArgs],
 1407    assert((Head :- recorded(_, Var, Id), Var = NewArgs)).
 1408:- else. 1409:- if(sicstus). 1410:- endif. 1411assert_cyclic(Term) :-
 1412    assert(Term).
 1413:- endif. 1414
 1415
 1416		 /*******************************
 1417		 *             JOBS             *
 1418		 *******************************/
 1419
 1420:- if(current_prolog_flag(threads, true)). 1421
 1422:- dynamic
 1423       job_data/2,		% Queue, Threads
 1424       scheduled_unit/1. 1425
 1426schedule_unit(_:[]) :-
 1427    !.
 1428schedule_unit(UnitAndTests) :-
 1429    UnitAndTests = Unit:_Tests,
 1430    job_data(Queue, _),
 1431    !,
 1432    assertz(scheduled_unit(Unit)),
 1433    thread_send_message(Queue, unit(UnitAndTests)).
 1434schedule_unit(Unit) :-
 1435    run_unit(Unit).
 1436
 1437%!  setup_jobs(+Count) is det.
 1438%
 1439%   Setup threads for concurrent testing.
 1440
 1441setup_jobs(Count) :-
 1442    current_prolog_flag(cpu_count, Cores),
 1443    current_test_flag(test_options, Options),
 1444    option(concurrent(true), Options),
 1445    option(jobs(Jobs0), Options, Cores),
 1446    Jobs is min(Count, Jobs0),
 1447    Jobs > 1,
 1448    !,
 1449    message_queue_create(Q, [alias(plunit_jobs)]),
 1450    length(TIDs, Jobs),
 1451    foldl(create_plunit_job(Q), TIDs, 1, _),
 1452    asserta(job_data(Q, TIDs)),
 1453    job_feedback(informational, jobs(Jobs)).
 1454setup_jobs(_) :-
 1455    job_feedback(informational, jobs(1)).
 1456
 1457create_plunit_job(Q, TID, N, N1) :-
 1458    N1 is N + 1,
 1459    atom_concat(plunit_job_, N, Alias),
 1460    thread_create(plunit_job(Q), TID, [alias(Alias)]).
 1461
 1462plunit_job(Queue) :-
 1463    repeat,
 1464    (   catch(thread_get_message(Queue, Job,
 1465				 [ timeout(10)
 1466				 ]),
 1467	      error(_,_), fail)
 1468    ->  job(Job),
 1469	fail
 1470    ;   !
 1471    ).
 1472
 1473job(unit(Unit:Tests)) =>
 1474    run_unit(Unit:Tests).
 1475
 1476cleanup_jobs :-
 1477    retract(job_data(Queue, TIDSs)),
 1478    !,
 1479    message_queue_destroy(Queue),
 1480    maplist(thread_join, TIDSs).
 1481cleanup_jobs.
 1482
 1483%!  job_wait is det.
 1484%
 1485%   Wait for all test jobs to finish.
 1486
 1487job_wait :-
 1488    thread_wait(\+ scheduled_unit(_),
 1489		[ wait_preds([scheduled_unit/1]),
 1490		  timeout(1)
 1491		]),
 1492    !.
 1493job_wait :-
 1494    job_data(_Queue, TIDs),
 1495    member(TID, TIDs),
 1496    thread_property(TID, status(running)),
 1497    !,
 1498    job_wait.
 1499job_wait.
 1500
 1501
 1502
 1503job_info(begin(unit(_Unit))) =>
 1504    true.
 1505job_info(end(unit(Unit, _Summary))) =>
 1506    retractall(scheduled_unit(Unit)).
 1507
 1508:- else.			% No jobs
 1509
 1510schedule_unit(Unit) :-
 1511    run_unit(Unit).
 1512
 1513setup_jobs(_) :-
 1514    print_message(silent, plunit(jobs(1))).
 1515cleanup_jobs.
 1516job_wait.
 1517job_info(_).
 1518
 1519:- endif. 1520
 1521
 1522
 1523		 /*******************************
 1524		 *            REPORTING         *
 1525		 *******************************/
 1526
 1527%!  begin_test(+Unit, +Test, +Line, +Progress) is det.
 1528%!  end_test(+Unit, +Test, +Line, +Progress) is det.
 1529%
 1530%   Maintain running/5 and report a test has started/is ended using
 1531%   a =silent= message:
 1532%
 1533%       * plunit(begin(Unit:Test, File:Line, Progress))
 1534%       * plunit(end(Unit:Test, File:Line, Progress))
 1535%
 1536%   @see message_hook/3 for intercepting these messages
 1537
 1538begin_test(Unit, Test, Line, Progress) :-
 1539    thread_self(Me),
 1540    assert(running(Unit, Test, Line, Progress, Me)),
 1541    unit_file(Unit, File),
 1542    test_count(Total),
 1543    job_feedback(information, begin(Unit:Test, File:Line, Progress/Total)).
 1544
 1545end_test(Unit, Test, Line, Progress) :-
 1546    thread_self(Me),
 1547    retractall(running(_,_,_,_,Me)),
 1548    unit_file(Unit, File),
 1549    test_count(Total),
 1550    job_feedback(information, end(Unit:Test, File:Line, Progress/Total)).
 1551
 1552%!  running_tests is det.
 1553%
 1554%   Print the currently running test.
 1555
 1556running_tests :-
 1557    running_tests(Running),
 1558    print_message(informational, plunit(running(Running))).
 1559
 1560running_tests(Running) :-
 1561    test_count(Total),
 1562    findall(running(Unit:Test, File:Line, Progress/Total, Thread),
 1563	    (   running(Unit, Test, Line, Progress, Thread),
 1564		unit_file(Unit, File)
 1565	    ), Running).
 1566
 1567
 1568%!  current_test(?Unit, ?Test, ?Line, ?Body, ?Options) is nondet.
 1569%
 1570%   True when a test with the specified properties is loaded.
 1571
 1572current_test(Unit, Test, Line, Body, Options) :-
 1573    current_unit(Unit, Module, _Supers, _UnitOptions),
 1574    Module:'unit test'(Test, Line, Options, Body).
 1575
 1576%!  current_test_unit(?Unit, ?Options) is nondet.
 1577%
 1578%   True when a Unit is a current unit test declared with Options.
 1579
 1580current_test_unit(Unit, UnitOptions) :-
 1581    current_unit(Unit, _Module, _Supers, UnitOptions).
 1582
 1583
 1584count(Goal, Count) :-
 1585    aggregate_all(count, Goal, Count).
 1586
 1587%!  test_summary(?Unit, -Summary) is det.
 1588%
 1589%   True when Summary is a dict that reports the main statistics
 1590%   about the executed tests.
 1591
 1592test_summary(Unit, Summary) :-
 1593    count(failed(Unit, _0Test, _0Line, _Reason, _0Time), Failed),
 1594    count(timeout(Unit, _0Test, _0Line, _Limit, _0Time), Timeout),
 1595    count(passed(Unit, _0Test, _0Line, _Det, _0Time), Passed),
 1596    count(blocked(Unit, _0Test, _0Line, _0Reason), Blocked),
 1597    test_count(Total),
 1598    Summary = plunit{total:Total,
 1599		     passed:Passed,
 1600		     failed:Failed,
 1601		     timeout:Timeout,
 1602		     blocked:Blocked}.
 1603
 1604test_summary_passed(Summary) :-
 1605    _{failed: 0} :< Summary.
 1606
 1607%!  report is det.
 1608%
 1609%   Print a summary of the tests that ran.
 1610
 1611report :-
 1612    test_summary(_, Summary),
 1613    print_message(silent, plunit(Summary)),
 1614    _{ passed:Passed,
 1615       failed:Failed,
 1616       timeout:Timeout,
 1617       blocked:Blocked
 1618     } :< Summary,
 1619    (   Passed+Failed+Timeout+Blocked =:= 0
 1620    ->  info(plunit(no_tests))
 1621    ;   Failed+Timeout+Blocked =:= 0
 1622    ->  report_fixme,
 1623        test_count(Total),
 1624	info(plunit(all_passed(Total, Passed)))
 1625    ;   report_blocked(Blocked),
 1626	report_fixme,
 1627	report_failed(Failed),
 1628	report_timeout(Timeout),
 1629	info(plunit(passed(Passed)))
 1630    ).
 1631
 1632report_blocked(0) =>
 1633    true.
 1634report_blocked(Blocked) =>
 1635    info(plunit(blocked(Blocked))),
 1636    (   blocked(Unit, Name, Line, Reason),
 1637	unit_file(Unit, File),
 1638	print_message(informational,
 1639		      plunit(blocked(File:Line, Name, Reason))),
 1640	fail ; true
 1641    ).
 1642
 1643report_failed(Failed) :-
 1644    print_message(error, plunit(failed(Failed))).
 1645
 1646report_timeout(Count) :-
 1647    print_message(warning, plunit(timeout(Count))).
 1648
 1649report_fixme :-
 1650    report_fixme(_,_,_).
 1651
 1652report_fixme(TuplesF, TuplesP, TuplesN) :-
 1653    fixme(failed, TuplesF, Failed),
 1654    fixme(passed, TuplesP, Passed),
 1655    fixme(nondet, TuplesN, Nondet),
 1656    print_message(informational, plunit(fixme(Failed, Passed, Nondet))).
 1657
 1658
 1659fixme(How, Tuples, Count) :-
 1660    findall(fixme(Unit, Name, Line, Reason, How),
 1661	    fixme(Unit, Name, Line, Reason, How), Tuples),
 1662    length(Tuples, Count).
 1663
 1664report_failure(Unit, Name, Progress, Line, Error,
 1665	       Time, Output, _Options) =>
 1666    test_count(Total),
 1667    job_feedback(error, failed(Unit:Name, Progress/Total, Line,
 1668			       Error, Time, Output)).
 1669
 1670
 1671%!  test_report(+What) is det.
 1672%
 1673%   Produce reports on test  results  after   the  run.  Currently  only
 1674%   supports `fixme` for What.
 1675
 1676test_report(fixme) :-
 1677    !,
 1678    report_fixme(TuplesF, TuplesP, TuplesN),
 1679    append([TuplesF, TuplesP, TuplesN], Tuples),
 1680    print_message(informational, plunit(fixme(Tuples))).
 1681test_report(What) :-
 1682    throw_error(domain_error(report_class, What), _).
 1683
 1684
 1685		 /*******************************
 1686		 *             INFO             *
 1687		 *******************************/
 1688
 1689%!  unit_file(+Unit, -File) is det.
 1690%!  unit_file(-Unit, +File) is nondet.
 1691
 1692unit_file(Unit, File) :-
 1693    current_unit(Unit, Module, _Context, _Options),
 1694    current_module(Module, File),
 1695    !.
 1696unit_file(Unit, PlFile) :-
 1697    nonvar(PlFile),
 1698    test_file_for(TestFile, PlFile),
 1699    current_module(Module, TestFile),
 1700    current_unit(Unit, Module, _Context, _Options).
 1701
 1702
 1703		 /*******************************
 1704		 *             FILES            *
 1705		 *******************************/
 1706
 1707%!  load_test_files(+Options) is det.
 1708%
 1709%   Load .plt test-files related to loaded source-files.
 1710
 1711load_test_files(_Options) :-
 1712    (   source_file(File),
 1713	file_name_extension(Base, Old, File),
 1714	Old \== plt,
 1715	file_name_extension(Base, plt, TestFile),
 1716	exists_file(TestFile),
 1717	(   test_file_for(TestFile, File)
 1718	->  true
 1719	;   load_files(TestFile,
 1720		       [ if(changed),
 1721			 imports([])
 1722		       ]),
 1723	    asserta(test_file_for(TestFile, File))
 1724	),
 1725	fail ; true
 1726    ).
 1727
 1728
 1729
 1730		 /*******************************
 1731		 *           MESSAGES           *
 1732		 *******************************/
 1733
 1734%!  info(+Term)
 1735%
 1736%   Runs print_message(Level, Term), where Level is   one of `silent` or
 1737%   `informational` (default).
 1738
 1739info(Term) :-
 1740    message_level(Level),
 1741    print_message(Level, Term).
 1742
 1743%!  progress(+UnitTest, +Progress, +Result, +Time) is det.
 1744%
 1745%   Test Unit:Name completed in Time. Result is the result and is one of
 1746%
 1747%     - passed
 1748%     - failed
 1749%     - assertion
 1750%     - nondet
 1751%     - fixme(passed)
 1752%     - fixme(nondet)
 1753%     - fixme(failed)
 1754%     - forall(end, Nth, FTotal)
 1755%       Pseudo result for completion of a forall(Gen,Test) set.  Mapped
 1756%       to forall(FTotal, FFailed)
 1757
 1758progress(UnitTest, _Progress, forall(end, Nth, FTotal), Time) =>
 1759    (   retract(forall_failures(Nth, FFailed))
 1760    ->  true
 1761    ;   FFailed = 0
 1762    ),
 1763    test_count(Total),
 1764    job_feedback(information, progress(UnitTest, forall(FTotal,FFailed), Nth/Total, Time)).
 1765progress(UnitTest, Progress, Result, Time), Progress = forall(_Vars, Nth-_I) =>
 1766    with_mutex(plunit_forall_counter,
 1767               update_forall_failures(Nth, Result)),
 1768    test_count(Total),
 1769    job_feedback(information, progress(UnitTest, Result, Progress/Total, Time)).
 1770progress(UnitTest, Progress, Result, Time) =>
 1771    test_count(Total),
 1772    job_feedback(information, progress(UnitTest, Result, Progress/Total, Time)).
 1773
 1774update_forall_failures(_Nth, passed) =>
 1775    true.
 1776update_forall_failures(Nth, _) =>
 1777    (   retract(forall_failures(Nth, Failed0))
 1778    ->  true
 1779    ;   Failed0 = 0
 1780    ),
 1781    Failed is Failed0+1,
 1782    asserta(forall_failures(Nth, Failed)).
 1783
 1784message_level(Level) :-
 1785    current_test_flag(test_options, Options),
 1786    option(silent(Silent), Options, false),
 1787    (   Silent == false
 1788    ->  Level = informational
 1789    ;   Level = silent
 1790    ).
 1791
 1792locationprefix(File:Line) -->
 1793    !,
 1794    [ url(File:Line), ':\n\t' ].
 1795locationprefix(test(Unit,_Test,Line)) -->
 1796    !,
 1797    { unit_file(Unit, File) },
 1798    locationprefix(File:Line).
 1799locationprefix(unit(Unit)) -->
 1800    !,
 1801    [ 'PL-Unit: unit ~w: '-[Unit] ].
 1802locationprefix(FileLine) -->
 1803    { throw_error(type_error(locationprefix,FileLine), _) }.
 1804
 1805:- discontiguous
 1806    message//1. 1807:- '$hide'(message//1). 1808
 1809message(error(context_error(plunit_close(Name, -)), _)) -->
 1810    [ 'PL-Unit: cannot close unit ~w: no open unit'-[Name] ].
 1811message(error(context_error(plunit_close(Name, Start)), _)) -->
 1812    [ 'PL-Unit: cannot close unit ~w: current unit is ~w'-[Name, Start] ].
 1813message(plunit(nondet(File, Line, Name))) -->
 1814    locationprefix(File:Line),
 1815    [ 'PL-Unit: Test ~w: Test succeeded with choicepoint'- [Name] ].
 1816message(error(plunit(incompatible_options, Tests), _)) -->
 1817    [ 'PL-Unit: incompatible test-options: ~p'-[Tests] ].
 1818message(plunit(sto(true))) -->
 1819    [ 'Option sto(true) is ignored.  See `occurs_check` option.'-[] ].
 1820
 1821					% Unit start/end
 1822message(plunit(jobs(1))) -->
 1823    !.
 1824message(plunit(jobs(N))) -->
 1825    [ 'Tesing with ~D parallel jobs'-[N] ].
 1826message(plunit(begin(_Unit))) -->
 1827    { tty_feedback },
 1828    !.
 1829message(plunit(begin(Unit))) -->
 1830    [ 'Start unit: ~w~n'-[Unit], flush ].
 1831message(plunit(end(_Unit, _Summary))) -->
 1832    { tty_feedback },
 1833    !.
 1834message(plunit(end(Unit, Summary))) -->
 1835    (   {test_summary_passed(Summary)}
 1836    ->  [ 'End unit ~w: passed (~3f sec CPU)'-[Unit, Summary.time.cpu] ]
 1837    ;   [ ansi(error, 'End unit ~w: **FAILED (~3f sec CPU)', [Unit, Summary.time.cpu]) ]
 1838    ).
 1839message(plunit(blocked(unit(Unit, Reason)))) -->
 1840    [ 'PL-Unit: ~w blocked: ~w'-[Unit, Reason] ].
 1841message(plunit(running([]))) -->
 1842    !,
 1843    [ 'PL-Unit: no tests running' ].
 1844message(plunit(running([One]))) -->
 1845    !,
 1846    [ 'PL-Unit: running ' ],
 1847    running(One).
 1848message(plunit(running(More))) -->
 1849    !,
 1850    [ 'PL-Unit: running tests:', nl ],
 1851    running(More).
 1852message(plunit(fixme([]))) --> !.
 1853message(plunit(fixme(Tuples))) -->
 1854    !,
 1855    fixme_message(Tuples).
 1856
 1857					% Blocked tests
 1858message(plunit(blocked(1))) -->
 1859    !,
 1860    [ 'one test is blocked:'-[] ].
 1861message(plunit(blocked(N))) -->
 1862    [ '~D tests are blocked:'-[N] ].
 1863message(plunit(blocked(Pos, Name, Reason))) -->
 1864    locationprefix(Pos),
 1865    test_name(Name, -),
 1866    [ ': ~w'-[Reason] ].
 1867
 1868					% fail/success
 1869message(plunit(no_tests)) -->
 1870    !,
 1871    [ 'No tests to run' ].
 1872message(plunit(all_passed(1, 1))) -->
 1873    !,
 1874    [ 'test passed' ].
 1875message(plunit(all_passed(Total, Total))) -->
 1876    !,
 1877    [ 'All ~D tests passed'-[Total] ].
 1878message(plunit(all_passed(Total, Count))) -->
 1879    !,
 1880    { SubTests is Count-Total },
 1881    [ 'All ~D (+~D sub-tests) tests passed'-[Total, SubTests] ].
 1882message(plunit(passed(Count))) -->
 1883    !,
 1884    [ '~D tests passed'-[Count] ].
 1885message(plunit(failed(0))) -->
 1886    !,
 1887    [].
 1888message(plunit(failed(1))) -->
 1889    !,
 1890    [ '1 test failed'-[] ].
 1891message(plunit(failed(N))) -->
 1892    [ '~D tests failed'-[N] ].
 1893message(plunit(timeout(0))) -->
 1894    !,
 1895    [].
 1896message(plunit(timeout(N))) -->
 1897    [ '~D tests timed out'-[N] ].
 1898message(plunit(fixme(0,0,0))) -->
 1899    [].
 1900message(plunit(fixme(Failed,0,0))) -->
 1901    !,
 1902    [ 'all ~D tests flagged FIXME failed'-[Failed] ].
 1903message(plunit(fixme(Failed,Passed,0))) -->
 1904    [ 'FIXME: ~D failed; ~D passed'-[Failed, Passed] ].
 1905message(plunit(fixme(Failed,Passed,Nondet))) -->
 1906    { TotalPassed is Passed+Nondet },
 1907    [ 'FIXME: ~D failed; ~D passed; (~D nondet)'-
 1908      [Failed, TotalPassed, Nondet] ].
 1909
 1910message(plunit(begin(Unit:Test, _Location, Progress))) -->
 1911    { tty_columns(SummaryWidth, _Margin),
 1912      test_name_summary(Test, SummaryWidth, NameS),
 1913      progress_string(Progress, ProgressS)
 1914    },
 1915    (   { tty_feedback,
 1916	  tty_clear_to_eol(CE)
 1917	}
 1918    ->  [ at_same_line, '\r[~w] ~w:~w ..~w'-[ProgressS, Unit, NameS,
 1919					     CE], flush ]
 1920    ;   { jobs(_) }
 1921    ->  [ '[~w] ~w:~w ..'-[ProgressS, Unit, NameS] ]
 1922    ;   [ '[~w] ~w:~w ..'-[ProgressS, Unit, NameS], flush ]
 1923    ).
 1924message(plunit(end(_UnitTest, _Location, _Progress))) -->
 1925    [].
 1926message(plunit(progress(_UnitTest, Status, _Progress, _Time))) -->
 1927    { Status = forall(_,_)
 1928    ; Status == assertion
 1929    },
 1930    !.
 1931message(plunit(progress(Unit:Test, Status, Progress, Time))) -->
 1932    { jobs(_),
 1933      !,
 1934      tty_columns(SummaryWidth, Margin),
 1935      test_name_summary(Test, SummaryWidth, NameS),
 1936      progress_string(Progress, ProgressS),
 1937      progress_tag(Status, Tag, _Keep, Style)
 1938    },
 1939    [ ansi(Style, '[~w] ~w:~w ~`.t ~w (~3f sec)~*|',
 1940	   [ProgressS, Unit, NameS, Tag, Time.wall, Margin]) ].
 1941message(plunit(progress(_UnitTest, Status, _Progress, Time))) -->
 1942    { tty_columns(_SummaryWidth, Margin),
 1943      progress_tag(Status, Tag, _Keep, Style)
 1944    },
 1945    [ at_same_line, ansi(Style, '~`.t ~w (~3f sec)~*|',
 1946			 [Tag, Time.wall, Margin]) ],
 1947    (   { tty_feedback }
 1948    ->  [flush]
 1949    ;   []
 1950    ).
 1951message(plunit(failed(Unit:Test, Progress, Line, Failure, _Time, Output))) -->
 1952    { unit_file(Unit, File) },
 1953    locationprefix(File:Line),
 1954    test_name(Test, Progress),
 1955    [': '-[] ],
 1956    failure(Failure),
 1957    test_output(Output).
 1958message(plunit(timeout(Unit:Test, Progress, Line, Limit, Output))) -->
 1959    { unit_file(Unit, File) },
 1960    locationprefix(File:Line),
 1961    test_name(Test, Progress),
 1962    [': '-[] ],
 1963    timeout(Limit),
 1964    test_output(Output).
 1965:- if(swi). 1966message(plunit(failed_assertion(Unit:Test, Line, AssertLoc,
 1967				Progress, Reason, Goal))) -->
 1968    { unit_file(Unit, File) },
 1969    locationprefix(File:Line),
 1970    test_name(Test, Progress),
 1971    [ ': assertion'-[] ],
 1972    assertion_location(AssertLoc, File),
 1973    assertion_reason(Reason), ['\n\t'],
 1974    assertion_goal(Unit, Goal).
 1975
 1976assertion_location(File:Line, File) -->
 1977    [ ' at line ~w'-[Line] ].
 1978assertion_location(File:Line, _) -->
 1979    [ ' at ', url(File:Line) ].
 1980assertion_location(unknown, _) -->
 1981    [].
 1982
 1983assertion_reason(fail) -->
 1984    !,
 1985    [ ' failed'-[] ].
 1986assertion_reason(Error) -->
 1987    { message_to_string(Error, String) },
 1988    [ ' raised "~w"'-[String] ].
 1989
 1990assertion_goal(Unit, Goal) -->
 1991    { unit_module(Unit, Module),
 1992      unqualify(Goal, Module, Plain)
 1993    },
 1994    [ 'Assertion: ~p'-[Plain] ].
 1995
 1996unqualify(Var, _, Var) :-
 1997    var(Var),
 1998    !.
 1999unqualify(M:Goal, Unit, Goal) :-
 2000    nonvar(M),
 2001    unit_module(Unit, M),
 2002    !.
 2003unqualify(M:Goal, _, Goal) :-
 2004    callable(Goal),
 2005    predicate_property(M:Goal, imported_from(system)),
 2006    !.
 2007unqualify(Goal, _, Goal).
 2008
 2009test_output("") --> [].
 2010test_output(Output) -->
 2011    [ ansi(code, '~s', [Output]) ].
 2012
 2013:- endif. 2014					% Setup/condition errors
 2015message(plunit(error(Where, Context, _Output, throw(Exception)))) -->
 2016    locationprefix(Context),
 2017    { message_to_string(Exception, String) },
 2018    [ 'error in ~w: ~w'-[Where, String] ].
 2019message(plunit(error(Where, Context, _Output, false))) -->
 2020    locationprefix(Context),
 2021    [ 'setup failed in ~w'-[Where] ].
 2022
 2023                                        % delayed output
 2024message(plunit(test_output(_, Output))) -->
 2025    [ '~s'-[Output] ].
 2026					% Interrupts (SWI)
 2027:- if(swi). 2028message(interrupt(begin)) -->
 2029    { thread_self(Me),
 2030      running(Unit, Test, Line, STO, Me),
 2031      !,
 2032      unit_file(Unit, File)
 2033    },
 2034    [ 'Interrupted test '-[] ],
 2035    running(running(Unit:Test, File:Line, STO, Me)),
 2036    [nl],
 2037    '$messages':prolog_message(interrupt(begin)).
 2038message(interrupt(begin)) -->
 2039    '$messages':prolog_message(interrupt(begin)).
 2040:- endif. 2041
 2042test_name(Name, forall(Bindings, _Nth-I)) -->
 2043    !,
 2044    [ 'test ~w (~d-th forall bindings = ~p)'-[Name, I, Bindings] ].
 2045test_name(Name, _) -->
 2046    !,
 2047    [ 'test ~w'-[Name] ].
 2048
 2049det(true) -->
 2050    [ 'deterministic' ].
 2051det(false) -->
 2052    [ 'non-deterministic' ].
 2053
 2054running(running(Unit:Test, File:Line, Thread)) -->
 2055    thread(Thread),
 2056    [ '~q:~q at '-[Unit, Test], url(File:Line) ].
 2057running([H|T]) -->
 2058    ['\t'], running(H),
 2059    (   {T == []}
 2060    ->  []
 2061    ;   [nl], running(T)
 2062    ).
 2063
 2064thread(main) --> !.
 2065thread(Other) -->
 2066    [' [~w] '-[Other] ].
 2067
 2068:- if(swi). 2069write_term(T, OPS) -->
 2070    ['~W'-[T,OPS] ].
 2071:- else. 2072write_term(T, _OPS) -->
 2073    ['~q'-[T]].
 2074:- endif. 2075
 2076expected_got_ops_(Ex, E, OPS, Goals) -->
 2077    ['    Expected: '-[]], write_term(Ex, OPS), [nl],
 2078    ['    Got:      '-[]], write_term(E,  OPS), [],
 2079    ( { Goals = [] } -> []
 2080    ; [nl, '       with: '-[]], write_term(Goals, OPS), []
 2081    ).
 2082
 2083
 2084failure(List) -->
 2085    { is_list(List) },
 2086    !,
 2087    [ nl ],
 2088    failures(List).
 2089failure(Var) -->
 2090    { var(Var) },
 2091    !,
 2092    [ 'Unknown failure?' ].
 2093failure(succeeded(Time)) -->
 2094    !,
 2095    [ 'must fail but succeeded in ~2f seconds~n'-[Time] ].
 2096failure(wrong_error(Expected, Error)) -->
 2097    !,
 2098    { copy_term(Expected-Error, Ex-E, Goals),
 2099      numbervars(Ex-E-Goals, 0, _),
 2100      write_options(OPS)
 2101    },
 2102    [ 'wrong error'-[], nl ],
 2103    expected_got_ops_(Ex, E, OPS, Goals).
 2104failure(wrong_answer(cmp(Var, Cmp))) -->
 2105    { Cmp =.. [Op,Answer,Expected],
 2106      !,
 2107      copy_term(Expected-Answer, Ex-A, Goals),
 2108      numbervars(Ex-A-Goals, 0, _),
 2109      write_options(OPS)
 2110    },
 2111    [ 'wrong answer for ', ansi(code, '~w', [Var]),
 2112      ' (compared using ~w)'-[Op], nl ],
 2113    expected_got_ops_(Ex, A, OPS, Goals).
 2114failure(wrong_answer(Cmp)) -->
 2115    { Cmp =.. [Op,Answer,Expected],
 2116      !,
 2117      copy_term(Expected-Answer, Ex-A, Goals),
 2118      numbervars(Ex-A-Goals, 0, _),
 2119      write_options(OPS)
 2120    },
 2121    [ 'wrong answer (compared using ~w)'-[Op], nl ],
 2122    expected_got_ops_(Ex, A, OPS, Goals).
 2123failure(wrong_answer(CmpExpected, Bindings)) -->
 2124    { (   CmpExpected = all(Cmp)
 2125      ->  Cmp =.. [_Op1,_,Expected],
 2126	  Got = Bindings,
 2127	  Type = all
 2128      ;   CmpExpected = set(Cmp),
 2129	  Cmp =.. [_Op2,_,Expected0],
 2130	  sort(Expected0, Expected),
 2131	  sort(Bindings, Got),
 2132	  Type = set
 2133      )
 2134    },
 2135    [ 'wrong "~w" answer:'-[Type] ],
 2136    [ nl, '    Expected: ~q'-[Expected] ],
 2137    [ nl, '       Found: ~q'-[Got] ].
 2138:- if(swi). 2139failure(cmp_error(_Cmp, Error)) -->
 2140    { message_to_string(Error, Message) },
 2141    [ 'Comparison error: ~w'-[Message] ].
 2142failure(throw(Error)) -->
 2143    { Error = error(_,_),
 2144      !,
 2145      message_to_string(Error, Message)
 2146    },
 2147    [ 'received error: ~w'-[Message] ].
 2148:- endif. 2149failure(Why) -->
 2150    [ '~p'-[Why] ].
 2151
 2152failures([]) -->
 2153    !.
 2154failures([H|T]) -->
 2155    !,
 2156    failure(H), [nl],
 2157    failures(T).
 2158
 2159timeout(Limit) -->
 2160    [ 'Timeout exceeeded (~2f sec)'-[Limit] ].
 2161
 2162fixme_message([]) --> [].
 2163fixme_message([fixme(Unit, _Name, Line, Reason, How)|T]) -->
 2164    { unit_file(Unit, File) },
 2165    fixme_message(File:Line, Reason, How),
 2166    (   {T == []}
 2167    ->  []
 2168    ;   [nl],
 2169	fixme_message(T)
 2170    ).
 2171
 2172fixme_message(Location, Reason, failed) -->
 2173    [ 'FIXME: ~w: ~w'-[Location, Reason] ].
 2174fixme_message(Location, Reason, passed) -->
 2175    [ 'FIXME: ~w: passed ~w'-[Location, Reason] ].
 2176fixme_message(Location, Reason, nondet) -->
 2177    [ 'FIXME: ~w: passed (nondet) ~w'-[Location, Reason] ].
 2178
 2179
 2180write_options([ numbervars(true),
 2181		quoted(true),
 2182		portray(true),
 2183		max_depth(100),
 2184		attributes(portray)
 2185	      ]).
 2186
 2187%!  test_name_summary(+Term, +MaxLen, -Summary) is det.
 2188%
 2189%   Given the test id, generate  string that summarizes this in MaxLen
 2190%   characters.
 2191
 2192test_name_summary(Term, MaxLen, Summary) :-
 2193    summary_string(Term, Text),
 2194    atom_length(Text, Len),
 2195    (   Len =< MaxLen
 2196    ->  Summary = Text
 2197    ;   Pre is MaxLen - 8,
 2198        sub_string(Text, 0, Pre, _, PreText),
 2199        sub_string(Text, _, 5, 0, PostText),
 2200        format(string(Summary), '~w...~w', [PreText,PostText])
 2201    ).
 2202
 2203summary_string(@(Name,Vars), String) =>
 2204    format(string(String), '~W (using ~W)',
 2205           [ Name, [numbervars(true), quoted(false)],
 2206             Vars, [numbervars(true), portray(true), quoted(true)]
 2207           ]).
 2208summary_string(Name, String) =>
 2209    term_string(Name, String, [numbervars(true), quoted(false)]).
 2210
 2211%!  progress_string(+Progress, -S) is det.
 2212%
 2213%   True when S is a string representation for the test progress.
 2214
 2215progress_string(forall(_Vars, N-I)/Total, S) =>
 2216    format(string(S), '~w-~w/~w', [N,I,Total]).
 2217progress_string(Progress, S) =>
 2218    term_string(Progress, S).
 2219
 2220%!  progress_tag(+Status, -Tag, -Keep, -Style) is det.
 2221%
 2222%   Given a progress status, determine the status tag, whether we must
 2223%   preserve the  line and the Style  we must use to  print the status
 2224%   line.
 2225
 2226progress_tag(passed,        Tag, Keep, Style) =>
 2227    Tag = passed, Keep = false, Style = comment.
 2228progress_tag(fixme(passed), Tag, Keep, Style) =>
 2229    Tag = passed, Keep = false, Style = comment.
 2230progress_tag(fixme(_),      Tag, Keep, Style) =>
 2231    Tag = fixme, Keep = true, Style = warning.
 2232progress_tag(nondet,        Tag, Keep, Style) =>
 2233    Tag = '**NONDET', Keep = true, Style = warning.
 2234progress_tag(timeout(_Limit), Tag, Keep, Style) =>
 2235    Tag = '**TIMEOUT', Keep = true, Style = warning.
 2236progress_tag(assertion,     Tag, Keep, Style) =>
 2237    Tag = '**FAILED', Keep = true, Style = error.
 2238progress_tag(failed,        Tag, Keep, Style) =>
 2239    Tag = '**FAILED', Keep = true, Style = error.
 2240progress_tag(forall(_,0),   Tag, Keep, Style) =>
 2241    Tag = passed, Keep = false, Style = comment.
 2242progress_tag(forall(_,_),   Tag, Keep, Style) =>
 2243    Tag = '**FAILED', Keep = true, Style = error.
 2244
 2245
 2246		 /*******************************
 2247		 *      CONCURRENT STATUS       *
 2248		 *******************************/
 2249
 2250/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 2251
 2252This part deals with interactive feedback when we are running multiple
 2253 threads.   The terminal  window  cannot  work on  top  of the  Prolog
 2254 message  infrastructure and  (thus)  we have  to  use more  low-level
 2255 means.
 2256
 2257
 2258- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
 2259
 2260:- dynamic
 2261       jobs/1,			% Count
 2262       job_window/1,		% Count
 2263       job_status_line/3.	% Job, Format, Args
 2264
 2265job_feedback(_, jobs(Jobs)) :-
 2266    retractall(jobs(_)),
 2267    Jobs > 1,
 2268    asserta(jobs(Jobs)),
 2269    tty_feedback,
 2270    !,
 2271    retractall(job_window(_)),
 2272    asserta(job_window(Jobs)),
 2273    retractall(job_status_line(_,_,_)),
 2274    jobs_redraw.
 2275job_feedback(_, jobs(Jobs)) :-
 2276    !,
 2277    retractall(job_window(_)),
 2278    info(plunit(jobs(Jobs))).
 2279job_feedback(_, Msg) :-
 2280    job_window(_),
 2281    !,
 2282    with_mutex(plunit_feedback, job_feedback(Msg)).
 2283job_feedback(Level, Msg) :-
 2284    print_message(Level, plunit(Msg)).
 2285
 2286job_feedback(begin(Unit:Test, _Location, Progress)) =>
 2287    tty_columns(SummaryWidth, _Margin),
 2288    test_name_summary(Test, SummaryWidth, NameS),
 2289    progress_string(Progress, ProgressS),
 2290    tty_clear_to_eol(CE),
 2291    job_format(comment, '\r[~w] ~w:~w ..~w',
 2292	       [ProgressS, Unit, NameS, CE]),
 2293    flush_output.
 2294job_feedback(end(_UnitTest, _Location, _Progress)) =>
 2295    true.
 2296job_feedback(progress(_UnitTest, Status, _Progress, Time)) =>
 2297    (   hide_progress(Status)
 2298    ->  true
 2299    ;   tty_columns(_SummaryWidth, Margin),
 2300	progress_tag(Status, Tag, _Keep, Style),
 2301	job_finish(Style, '~`.t ~w (~3f sec)~*|',
 2302		   [Tag, Time.wall, Margin])
 2303    ).
 2304job_feedback(failed(UnitTest, Progress, Line, Error, Time, Output)) =>
 2305    tty_columns(_SummaryWidth, Margin),
 2306    progress_tag(failed, Tag, _Keep, Style),
 2307    job_finish(Style, '~`.t ~w (~3f sec)~*|',
 2308	       [Tag, Time.wall, Margin]),
 2309    print_test_output(Error, Output),
 2310    (   (   Error = timeout(_)	% Status line suffices
 2311	;   Error == assertion	% We will get an failed test later
 2312	)
 2313    ->  true
 2314    ;   print_message(Style, plunit(failed(UnitTest, Progress, Line,
 2315					   Error, Time, "")))
 2316    ),
 2317    jobs_redraw.
 2318job_feedback(begin(_Unit)) => true.
 2319job_feedback(end(_Unit, _Summary)) => true.
 2320
 2321hide_progress(assertion).
 2322hide_progress(forall(_,_)).
 2323hide_progress(failed).
 2324hide_progress(timeout(_)).
 2325
 2326print_test_output(_, "") => true.
 2327print_test_output(assertion, Output) =>
 2328    print_message(debug, plunit(test_output(error, Output))).
 2329print_test_output(_, Output) =>
 2330    print_message(debug, plunit(test_output(informational, Output))).
 2331
 2332%!  jobs_redraw is det.
 2333%
 2334%   Redraw the job window.
 2335
 2336jobs_redraw :-
 2337    job_window(N),
 2338    !,
 2339    tty_columns(_, Width),
 2340    tty_header_line(Width),
 2341    forall(between(1,N,Line), job_redraw_worker(Line)),
 2342    tty_header_line(Width).
 2343jobs_redraw.
 2344
 2345job_redraw_worker(Line) :-
 2346    (   job_status_line(Line, Fmt, Args)
 2347    ->  ansi_format(comment, Fmt, Args)
 2348    ;   true
 2349    ),
 2350    nl.
 2351
 2352%!  job_format(+Style, +Fmt, +Args) is det.
 2353%!  job_format(+Job, +Style, +Fmt, +Args, +Save) is det.
 2354%
 2355%   Point should be  below the status window.  Format  Fmt+Args in the
 2356%   line Job using Style and return to the position below the window.
 2357
 2358job_format(Style, Fmt, Args) :-
 2359    job_self(Job),
 2360    job_format(Job, Style, Fmt, Args, true).
 2361
 2362%!  job_finish(+Style, +Fmt, +Args) is det.
 2363%!  job_finish(+Job, +Style, +Fmt, +Args) is det.
 2364%
 2365%   Complete  the status  line  for Job.   This  redraws the  original
 2366%   status line when we are using a job window.
 2367
 2368job_finish(Style, Fmt, Args) :-
 2369    job_self(Job),
 2370    job_finish(Job, Style, Fmt, Args).
 2371
 2372:- det(job_finish/4). 2373job_finish(Job, Style, Fmt, Args) :-
 2374    retract(job_status_line(Job, Fmt0, Args0)),
 2375    !,
 2376    string_concat(Fmt0, Fmt, Fmt1),
 2377    append(Args0, Args, Args1),
 2378    job_format(Job, Style, Fmt1, Args1, false).
 2379
 2380:- det(job_format/5). 2381job_format(Job, Style, Fmt, Args, Save) :-
 2382    job_window(Jobs),
 2383    Up is Jobs+2-Job,
 2384    flush_output(user_output),
 2385    tty_up_and_clear(Up),
 2386    ansi_format(Style, Fmt, Args),
 2387    (   Save == true
 2388    ->  retractall(job_status_line(Job, _, _)),
 2389	asserta(job_status_line(Job, Fmt, Args))
 2390    ;   true
 2391    ),
 2392    tty_down_and_home(Up),
 2393    flush_output(user_output).
 2394
 2395:- det(job_self/1). 2396job_self(Job) :-
 2397    job_window(N),
 2398    N > 1,
 2399    thread_self(Me),
 2400    split_string(Me, '_', '', [_,_,S]),
 2401    number_string(Job, S).
 2402
 2403%!  feedback is semidet.
 2404%
 2405%   provide feedback using the `tty`  format, which reuses the current
 2406%   output line if the test is successful.
 2407
 2408tty_feedback :-
 2409    has_tty,
 2410    current_test_flag(test_options, Options),
 2411    option(format(tty), Options, tty).
 2412
 2413has_tty :-
 2414    stream_property(user_output, tty(true)).
 2415
 2416tty_columns(SummaryWidth, Margin) :-
 2417    tty_width(W),
 2418    Margin is W-8,
 2419    SummaryWidth = max(20,Margin-50).
 2420
 2421tty_width(W) :-
 2422    current_predicate(tty_size/2),
 2423    catch(tty_size(_Rows, Cols), error(_,_), fail),
 2424    !,
 2425    W = Cols.
 2426tty_width(80).
 2427
 2428tty_header_line(Width) :-
 2429    ansi_format(comment, '~N~`\u2015t~*|~n', [Width]).
 2430
 2431tty_clear_to_eol(S) :-
 2432    tty_get_capability(ce, string, S),
 2433    !.
 2434tty_clear_to_eol('\e[K').
 2435
 2436tty_up_and_clear(Lines) :-
 2437    format(user_output, '\e[~dA\r\e[K', [Lines]).
 2438
 2439tty_down_and_home(Lines) :-
 2440    format(user_output, '\e[~dB\r', [Lines]).
 2441
 2442:- if(swi). 2443
 2444:- multifile
 2445    prolog:message/3,
 2446    user:message_hook/3. 2447
 2448prolog:message(Term) -->
 2449    message(Term).
 2450
 2451%       user:message_hook(+Term, +Kind, +Lines)
 2452
 2453user:message_hook(make(done(Files)), _, _) :-
 2454    make_run_tests(Files),
 2455    fail.                           % give other hooks a chance
 2456
 2457:- endif. 2458
 2459:- if(sicstus). 2460
 2461user:generate_message_hook(Message) -->
 2462    message(Message),
 2463    [nl].                           % SICStus requires nl at the end
 2464
 2465%!  user:message_hook(+Severity, +Message, +Lines) is semidet.
 2466%
 2467%   Redefine printing some messages. It appears   SICStus has no way
 2468%   to get multiple messages at the same   line, so we roll our own.
 2469%   As there is a lot pre-wired and   checked in the SICStus message
 2470%   handling we cannot reuse the lines. Unless I miss something ...
 2471
 2472user:message_hook(informational, plunit(begin(Unit)), _Lines) :-
 2473    format(user_error, '% PL-Unit: ~w ', [Unit]),
 2474    flush_output(user_error).
 2475user:message_hook(informational, plunit(end(_Unit)), _Lines) :-
 2476    format(user, ' done~n', []).
 2477
 2478:- endif.