/*  Part of SWI-Prolog

    Author:        Jan Wielemaker
    E-mail:        J.Wielemaker@vu.nl
    WWW:           http://www.swi-prolog.org
    Copyright (c)  2006-2023, University of Amsterdam
			      VU University Amsterdam
			      CWI, Amsterdam
			      SWI-Prolog Solutions b.v.
    All rights reserved.

    Redistribution and use in source and binary forms, with or without
    modification, are permitted provided that the following conditions
    are met:

    1. Redistributions of source code must retain the above copyright
       notice, this list of conditions and the following disclaimer.

    2. Redistributions in binary form must reproduce the above copyright
       notice, this list of conditions and the following disclaimer in
       the documentation and/or other materials provided with the
       distribution.

    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
    POSSIBILITY OF SUCH DAMAGE.
*/

:- module(plunit,
	  [ set_test_options/1,         % +Options
	    begin_tests/1,              % +Name
	    begin_tests/2,              % +Name, +Options
	    end_tests/1,                % +Name
	    run_tests/0,                % Run all tests
	    run_tests/1,                % +Tests
	    run_tests/2,                % +Tests, +Options
	    load_test_files/1,          % +Options
	    running_tests/0,            % Prints currently running test
	    current_test/5,             % ?Unit,?Test,?Line,?Body,?Options
	    current_test_unit/2,        % ?Unit,?Options
	    test_report/1               % +What
	  ]).

/** <module> Unit Testing

Unit testing environment for SWI-Prolog and   SICStus Prolog. For usage,
please visit https://www.swi-prolog.org/pldoc/package/plunit.
*/

:- autoload(library(statistics), [call_time/2]).
:- autoload(library(apply),
            [maplist/3, include/3, maplist/2, foldl/4, partition/4]).
:- autoload(library(lists), [member/2, append/2, flatten/2, append/3]).
:- autoload(library(option), [ option/3, option/2, select_option/3 ]).
:- autoload(library(ordsets), [ord_intersection/3]).
:- autoload(library(error), [must_be/2, domain_error/2]).
:- autoload(library(aggregate), [aggregate_all/3]).
:- autoload(library(streams), [with_output_to/3]).
:- autoload(library(ansi_term), [ansi_format/3]).
:- if(exists_source(library(time))).
:- autoload(library(time), [call_with_time_limit/2]).
:- endif.

:- public
    unit_module/2.

:- meta_predicate
    valid_options(1, +),
    count(0, -).

		 /*******************************
		 *    CONDITIONAL COMPILATION   *
		 *******************************/

swi     :- catch(current_prolog_flag(dialect, swi), _, fail), !.
swi     :- catch(current_prolog_flag(dialect, yap), _, fail).
sicstus :- catch(current_prolog_flag(system_type, _), _, fail).

throw_error(Error_term,Impldef) :-
    throw(error(Error_term,context(Impldef,_))).

:- set_prolog_flag(generate_debug_info, false).
current_test_flag(optimise, Value) =>
    current_prolog_flag(optimise, Value).
current_test_flag(occurs_check, Value) =>
    (   current_prolog_flag(plunit_occurs_check, Value0)
    ->  Value = Value0
    ;   current_prolog_flag(occurs_check, Value)
    ).
current_test_flag(Name, Value), atom(Name) =>
    atom_concat(plunit_, Name, Flag),
    current_prolog_flag(Flag, Value).
current_test_flag(Name, Value), var(Name) =>
    global_test_option(Opt, _, _Type, _Default),
    functor(Opt, Name, 1),
    current_test_flag(Name, Value).

set_test_flag(Name, Value) :-
    Opt =.. [Name, Value],
    global_test_option(Opt),
    !,
    atom_concat(plunit_, Name, Flag),
    set_prolog_flag(Flag, Value).
set_test_flag(Name, _) :-
    domain_error(test_flag, Name).

current_test_flags(Flags) :-
    findall(Flag, current_test_flag(Flag), Flags).

current_test_flag(Opt) :-
    current_test_flag(Name, Value),
    Opt =.. [Name, Value].

% ensure expansion to avoid tracing
goal_expansion(forall(C,A),
	       \+ (C, \+ A)).
goal_expansion(current_module(Module,File),
	       module_property(Module, file(File))).


		 /*******************************
		 *            IMPORTS           *
		 *******************************/

:- initialization init_flags.

init_flags :-
    (   global_test_option(Option, _Value, _Type, Default),
	Default \== (-),
	Option =.. [Name,_],
	atom_concat(plunit_, Name, Flag),
	create_prolog_flag(Flag, Default, [keep(true)]),
	fail
    ;   true
    ).

%!  set_test_options(+Options)
%
%   Specifies how to deal with test suites.  Defined options are:
%
%    - load(+Load)
%      Whether or not the tests must be loaded.  Values are
%      `never`, `always`, `normal` (only if not optimised)
%
%    - run(+When)
%      When the tests are run.  Values are `manual`, `make`
%      or make(all).
%
%    - format(+Mode)
%      Currently one of `tty` or `log`.   `tty` uses terminal
%      control to overwrite successful tests, allowing the
%      user to see the currently running tests and output
%      from failed tests.  This is the default of the output
%      is a tty.  `log` prints a full log of the executed
%      tests and their result and is intended for non-interactive
%      usage.
%
%    - output(+When)
%      If `always`, emit all output as it is produced, if `never`,
%      suppress all output and if `on_failure`, emit the output
%      if the test fails.
%
%    - show_blocked(+Bool)
%      Show individual blocked tests during the report.
%
%    - occurs_check(+Mode)
%      Defines the default for the `occurs_check` flag during
%      testing.
%
%    - cleanup(+Bool)
%      If `true` (default =false), cleanup report at the end
%      of run_tests/1.  Used to improve cooperation with
%      memory debuggers such as dmalloc.
%
%    - jobs(Num)
%      Number of jobs to use for concurrent testing.  Default
%      is one, implying sequential testing.
%
%    - timeout(+Seconds)
%      Set timeout for each individual test.  This acts as a
%      default that may be overuled at the level of units or
%      individual tests.   A timeout of 0 or negative is handled
%      as _inifinite_.

set_test_options(Options) :-
    flatten([Options], List),
    maplist(set_test_option, List).

set_test_option(sto(true)) =>
    print_message(warning, plunit(sto(true))).
set_test_option(jobs(Jobs)) =>
    must_be(positive_integer, Jobs),
    set_test_option_flag(jobs(Jobs)).
set_test_option(Option),
  compound(Option), global_test_option(Option) =>
    set_test_option_flag(Option).
set_test_option(Option) =>
    domain_error(option, Option).

global_test_option(Opt) :-
    global_test_option(Opt, Value, Type, _Default),
    must_be(Type, Value).

global_test_option(load(Load), Load, oneof([never,always,normal]), normal).
global_test_option(output(Cond), Cond, oneof([always,on_failure]), on_failure).
global_test_option(format(Feedback), Feedback, oneof([tty,log]), tty).
global_test_option(silent(Silent), Silent, boolean, false).
global_test_option(show_blocked(Blocked), Blocked, boolean, false).
global_test_option(run(When), When, oneof([manual,make,make(all)]), make).
global_test_option(occurs_check(Mode), Mode, oneof([false,true,error]), -).
global_test_option(cleanup(Bool), Bool, boolean, true).
global_test_option(jobs(Count), Count, positive_integer, 1).
global_test_option(timeout(Number), Number, number, 3600).

set_test_option_flag(Option) :-
    Option =.. [Name, Value],
    set_test_flag(Name, Value).

%!  loading_tests
%
%   True if tests must be loaded.

loading_tests :-
    current_test_flag(load, Load),
    (   Load == always
    ->  true
    ;   Load == normal,
	\+ current_test_flag(optimise, true)
    ).

		 /*******************************
		 *            MODULE            *
		 *******************************/

:- dynamic
    loading_unit/4,                 % Unit, Module, File, OldSource
    current_unit/4,                 % Unit, Module, Context, Options
    test_file_for/2.                % ?TestFile, ?PrologFile

%!  begin_tests(+UnitName:atom) is det.
%!  begin_tests(+UnitName:atom, Options) is det.
%
%   Start a test-unit. UnitName is the  name   of  the test set. the
%   unit is ended by :- end_tests(UnitName).

begin_tests(Unit) :-
    begin_tests(Unit, []).

begin_tests(Unit, Options) :-
    must_be(atom, Unit),
    map_sto_option(Options, Options1),
    valid_options(test_set_option, Options1),
    make_unit_module(Unit, Name),
    source_location(File, Line),
    begin_tests(Unit, Name, File:Line, Options1).

map_sto_option(Options0, Options) :-
    select_option(sto(Mode), Options0, Options1),
    !,
    map_sto(Mode, Flag),
    Options = [occurs_check(Flag)|Options1].
map_sto_option(Options, Options).

map_sto(rational_trees, Flag) => Flag = false.
map_sto(finite_trees, Flag)   => Flag = true.
map_sto(Mode, _) => domain_error(sto, Mode).


:- if(swi).
begin_tests(Unit, Name, File:Line, Options) :-
    loading_tests,
    !,
    '$set_source_module'(Context, Context),
    (   current_unit(Unit, Name, Context, Options)
    ->  true
    ;   retractall(current_unit(Unit, Name, _, _)),
	assert(current_unit(Unit, Name, Context, Options))
    ),
    '$set_source_module'(Old, Name),
    '$declare_module'(Name, test, Context, File, Line, false),
    discontiguous(Name:'unit test'/4),
    '$set_predicate_attribute'(Name:'unit test'/4, trace, false),
    discontiguous(Name:'unit body'/2),
    asserta(loading_unit(Unit, Name, File, Old)).
begin_tests(Unit, Name, File:_Line, _Options) :-
    '$set_source_module'(Old, Old),
    asserta(loading_unit(Unit, Name, File, Old)).

:- else.

% we cannot use discontiguous as a goal in SICStus Prolog.

user:term_expansion((:- begin_tests(Set)),
		    [ (:- begin_tests(Set)),
		      (:- discontiguous(test/2)),
		      (:- discontiguous('unit body'/2)),
		      (:- discontiguous('unit test'/4))
		    ]).

begin_tests(Unit, Name, File:_Line, Options) :-
    loading_tests,
    !,
    (   current_unit(Unit, Name, _, Options)
    ->  true
    ;   retractall(current_unit(Unit, Name, _, _)),
	assert(current_unit(Unit, Name, -, Options))
    ),
    asserta(loading_unit(Unit, Name, File, -)).
begin_tests(Unit, Name, File:_Line, _Options) :-
    asserta(loading_unit(Unit, Name, File, -)).

:- endif.

%!  end_tests(+Name) is det.
%
%   Close a unit-test module.
%
%   @tbd    Run tests/clean module?
%   @tbd    End of file?

end_tests(Unit) :-
    loading_unit(StartUnit, _, _, _),
    !,
    (   Unit == StartUnit
    ->  once(retract(loading_unit(StartUnit, _, _, Old))),
	'$set_source_module'(_, Old)
    ;   throw_error(context_error(plunit_close(Unit, StartUnit)), _)
    ).
end_tests(Unit) :-
    throw_error(context_error(plunit_close(Unit, -)), _).

%!  make_unit_module(+Name, -ModuleName) is det.
%!  unit_module(+Name, -ModuleName) is det.

:- if(swi).

unit_module(Unit, Module) :-
    atom_concat('plunit_', Unit, Module).

make_unit_module(Unit, Module) :-
    unit_module(Unit, Module),
    (   current_module(Module),
	\+ current_unit(_, Module, _, _),
	predicate_property(Module:H, _P),
	\+ predicate_property(Module:H, imported_from(_M))
    ->  throw_error(permission_error(create, plunit, Unit),
		    'Existing module')
    ;  true
    ).

:- else.

:- dynamic
    unit_module_store/2.

unit_module(Unit, Module) :-
    unit_module_store(Unit, Module),
    !.

make_unit_module(Unit, Module) :-
    prolog_load_context(module, Module),
    assert(unit_module_store(Unit, Module)).

:- endif.

		 /*******************************
		 *           EXPANSION          *
		 *******************************/

%!  expand_test(+Name, +Options, +Body, -Clause) is det.
%
%   Expand test(Name, Options) :-  Body  into   a  clause  for
%   'unit test'/4 and 'unit body'/2.

expand_test(Name, Options0, Body,
	    [ 'unit test'(Name, Line, Options, Module:'unit body'(Id, Vars)),
	      ('unit body'(Id, Vars) :- !, Body)
	    ]) :-
    source_location(_File, Line),
    prolog_load_context(module, Module),
    (   prolog_load_context(variable_names, Bindings)
    ->  true
    ;   Bindings = []
    ),
    atomic_list_concat([Name, '@line ', Line], Id),
    term_variables(Options0, OptionVars0), sort(OptionVars0, OptionVars),
    term_variables(Body, BodyVars0), sort(BodyVars0, BodyVars),
    ord_intersection(OptionVars, BodyVars, VarList),
    Vars =.. [vars|VarList],
    (   is_list(Options0)           % allow for single option without list
    ->  Options1 = Options0
    ;   Options1 = [Options0]
    ),
    maplist(expand_option(Bindings), Options1, Options2),
    join_true_options(Options2, Options3),
    map_sto_option(Options3, Options4),
    valid_options(test_option, Options4),
    valid_test_mode(Options4, Options).

expand_option(_, Var, _) :-
    var(Var),
    !,
    throw_error(instantiation_error,_).
expand_option(Bindings, Cmp, true(Cond)) :-
    cmp(Cmp),
    !,
    var_cmp(Bindings, Cmp, Cond).
expand_option(_, error(X), throws(error(X, _))) :- !.
expand_option(_, exception(X), throws(X)) :- !. % SICStus 4 compatibility
expand_option(_, error(F,C), throws(error(F,C))) :- !. % SICStus 4 compatibility
expand_option(_, true, true(true)) :- !.
expand_option(_, O, O).

cmp(_ == _).
cmp(_ = _).
cmp(_ =@= _).
cmp(_ =:= _).

var_cmp(Bindings, Expr, cmp(Name, Expr)) :-
    arg(_, Expr, Var),
    var(Var),
    member(Name=V, Bindings),
    V == Var,
    !.
var_cmp(_, Expr, Expr).

join_true_options(Options0, Options) :-
    partition(true_option, Options0, True, Rest),
    True \== [],
    !,
    maplist(arg(1), True, Conds0),
    flatten(Conds0, Conds),
    Options = [true(Conds)|Rest].
join_true_options(Options, Options).

true_option(true(_)).

valid_test_mode(Options0, Options) :-
    include(test_mode, Options0, Tests),
    (   Tests == []
    ->  Options = [true([true])|Options0]
    ;   Tests = [_]
    ->  Options = Options0
    ;   throw_error(plunit(incompatible_options, Tests), _)
    ).

test_mode(true(_)).
test_mode(all(_)).
test_mode(set(_)).
test_mode(fail).
test_mode(throws(_)).


%!  expand(+Term, -Clauses) is semidet.

expand(end_of_file, _) :-
    loading_unit(Unit, _, _, _),
    !,
    end_tests(Unit),                % warn?
    fail.
expand((:-end_tests(_)), _) :-
    !,
    fail.
expand(_Term, []) :-
    \+ loading_tests.
expand((test(Name) :- Body), Clauses) :-
    !,
    expand_test(Name, [], Body, Clauses).
expand((test(Name, Options) :- Body), Clauses) :-
    !,
    expand_test(Name, Options, Body, Clauses).
expand(test(Name), _) :-
    !,
    throw_error(existence_error(body, test(Name)), _).
expand(test(Name, _Options), _) :-
    !,
    throw_error(existence_error(body, test(Name)), _).

:- multifile
    system:term_expansion/2.

system:term_expansion(Term, Expanded) :-
    (   loading_unit(_, _, File, _)
    ->  source_location(ThisFile, _),
	(   File == ThisFile
	->  true
	;   source_file_property(ThisFile, included_in(File, _))
	),
	expand(Term, Expanded)
    ).


		 /*******************************
		 *             OPTIONS          *
		 *******************************/

%!  valid_options(:Pred, +Options) is det.
%
%   Verify Options to be a list of valid options according to
%   Pred.
%
%   @error `type_error` or `instantiation_error`.

valid_options(Pred, Options) :-
    must_be(list, Options),
    verify_options(Options, Pred).

verify_options([], _).
verify_options([H|T], Pred) :-
    (   call(Pred, H)
    ->  verify_options(T, Pred)
    ;   throw_error(domain_error(Pred, H), _)
    ).

valid_options(Pred, Options0, Options, Rest) :-
    must_be(list, Options0),
    partition(Pred, Options0, Options, Rest).

%!  test_option(+Option) is semidet.
%
%   True if Option is a valid option for test(Name, Options).

test_option(Option) :-
    test_set_option(Option),
    !.
test_option(true(_)).
test_option(fail).
test_option(throws(_)).
test_option(all(_)).
test_option(set(_)).
test_option(nondet).
test_option(fixme(_)).
test_option(forall(X)) :-
    must_be(callable, X).
test_option(timeout(Seconds)) :-
    must_be(number, Seconds).

%!  test_option(+Option) is semidet.
%
%   True if Option is a valid option for :- begin_tests(Name,
%   Options).

test_set_option(blocked(X)) :-
    must_be(ground, X).
test_set_option(condition(X)) :-
    must_be(callable, X).
test_set_option(setup(X)) :-
    must_be(callable, X).
test_set_option(cleanup(X)) :-
    must_be(callable, X).
test_set_option(occurs_check(V)) :-
    must_be(oneof([false,true,error]), V).
test_set_option(concurrent(V)) :-
    must_be(boolean, V),
    print_message(informational, plunit(concurrent)).
test_set_option(timeout(Seconds)) :-
    must_be(number, Seconds).

		 /*******************************
		 *             UTIL		*
		 *******************************/

:- meta_predicate
       reify_tmo(0, -, +),
       reify(0, -),
       capture_output(0,-),
       capture_output(0,-,+),
       got_messages(0,-).

%!  reify_tmo(:Goal, -Result, +Options) is det.

:- if(current_predicate(call_with_time_limit/2)).
reify_tmo(Goal, Result, Options) :-
    option(timeout(Time), Options),
    Time > 0,
    !,
    reify(call_with_time_limit(Time, Goal), Result0),
    (   Result0 = throw(time_limit_exceeded)
    ->  Result = throw(time_limit_exceeded(Time))
    ;   Result = Result0
    ).
:- endif.
reify_tmo(Goal, Result, _Options) :-
    reify(Goal, Result).

%!  reify(:Goal, -Result) is det.
%
%   Call  Goal  and  unify  Result  with   one  of  `true`,  `false`  or
%   `throw(E)`.

reify(Goal, Result) :-
    (   catch(Goal, E, true)
    ->  (   var(E)
	->  Result = true
	;   Result = throw(E)
	)
    ;   Result = false
    ).

%!  capture_output(:Goal, -Output) is semidet.
%!  capture_output(:Goal, -Output, +Options) is semidet.
%
%   @arg Output is a pair `Msgs-String`, where  `Msgs` is a boolean that
%   is true if there were messages that   require a non-zero exit status
%   and Output contains the output as a string.

capture_output(Goal, Output) :-
    current_test_flag(output, OutputMode),
    capture_output(Goal, Output, [output(OutputMode)]).

capture_output(Goal, Msgs-Output, Options) :-
    option(output(How), Options, always),
    (   How == always
    ->  call(Goal),
        Msgs = false                % irrelavant
    ;   with_output_to(string(Output), got_messages(Goal, Msgs),
                       [ capture([user_output, user_error]),
                         color(true)
                       ])
    ).

%!  got_messages(:Goal, -Result)

got_messages(Goal, Result) :-
    (   current_prolog_flag(on_warning, status)
    ;   current_prolog_flag(on_error, status)
    ), !,
    nb_delete(plunit_got_message),
    setup_call_cleanup(
        asserta(( user:thread_message_hook(_Term, Kind, _Lines) :-
                      got_message(Kind), fail), Ref),
        Goal,
        erase(Ref)),
    (   nb_current(plunit_got_message, true)
    ->  Result = true
    ;   Result = false
    ).
got_messages(Goal, false) :-
    call(Goal).

:- public got_message/1.
got_message(warning) :-
    current_prolog_flag(on_warning, status), !,
    nb_setval(plunit_got_message, true).
got_message(error) :-
    current_prolog_flag(on_error, status), !,
    nb_setval(plunit_got_message, true).


		 /*******************************
		 *        RUNNING TOPLEVEL      *
		 *******************************/

:- dynamic
    output_streams/2,               % Output, Error
    test_count/1,                   % Count
    passed/5,                       % Unit, Test, Line, Det, Time
    failed/5,                       % Unit, Test, Line, Reason, Time
    timeout/5,                      % Unit, Test, Line, Limit, Time
    failed_assertion/7,             % Unit, Test, Line, ALoc, STO, Reason, Goal
    blocked/4,                      % Unit, Test, Line, Reason
    fixme/5,                        % Unit, Test, Line, Reason, Status
    running/5,                      % Unit, Test, Line, STO, Thread
    forall_failures/2.              % Nth, Failures

%!  run_tests is semidet.
%!  run_tests(+TestSet) is semidet.
%!  run_tests(+TestSet, +Options) is semidet.
%
%   Run tests and report about the   results.  The predicate run_tests/0
%   runs all known tests that are not blocked. The predicate run_tests/1
%   takes a specification of tests  to  run.
%
%   The predicate run_tests/2 is  synchronized. Concurrent testing may
%   be     achieved    using     the     relevant    options.      See
%   set_test_options/1. Options are  passed to set_test_options/1.  In
%   addition the following options are processed:
%
%     - summary(-Summary)
%       Unify Summary do a dict holding the keys below.  The value of
%       these keys is an integer describing the number of tests.  If
%       this option is given, run_tests/2 does not fail if some tests
%       failed.
%
%       - total
%       - passed
%       - failed
%       - timeout
%       - blocked
%
%   @arg  TestSet  is either  a  single  specification  or a  list  of
%   specifications. Each single specification is  either the name of a
%   test-unit  or a  term <test-unit>:<test>,  denoting a  single test
%   within a unit.  If TestSet is `all`, all known tests are executed.

run_tests :-
    run_tests(all).

run_tests(Set) :-
    run_tests(Set, []).

run_tests(all, Options) :-
    !,
    findall(Unit, current_test_unit(Unit,_), Units),
    run_tests(Units, Options).
run_tests(Set, Options) :-
    valid_options(global_test_option, Options, Global, Rest),
    current_test_flags(Old),
    setup_call_cleanup(
	set_test_options(Global),
	( flatten([Set], List),
	  maplist(runnable_tests, List, Units),
	  with_mutex(plunit, run_tests_sync(Units, Rest))
	),
	set_test_options(Old)).

run_tests_sync(Units0, Options) :-
    cleanup,
    count_tests(Units0, Units, Count),
    asserta(test_count(Count)),
    save_output_state,
    setup_call_cleanup(
	setup_jobs(Count),
	setup_call_cleanup(
	    setup_trap_assertions(Ref),
	    ( call_time(run_units(Units, Options), Time),
              test_summary(_All, Summary)
            ),
	    report_and_cleanup(Ref, Time, Options)),
	cleanup_jobs),
    (   option(summary(Summary), Options)
    ->  true
    ;   test_summary_passed(Summary) % fail if some test failed
    ).

%!  report_and_cleanup(+Ref, +Time, +Options)
%
%   Undo changes to the environment   (trapping  assertions), report the
%   results and cleanup.

report_and_cleanup(Ref, Time, Options) :-
    cleanup_trap_assertions(Ref),
    report(Time, Options),
    cleanup_after_test.


%!  run_units_and_check_errors(+Units, +Options) is semidet.
%
%   Run all test units and succeed if all tests passed.

run_units(Units, _Options) :-
    maplist(schedule_unit, Units),
    job_wait(_).

%!  runnable_tests(+Spec, -Plan) is det.
%
%   Change a Unit+Test spec  into  a   plain  `Unit:Tests`  lists, where
%   blocked tests or tests whose condition   fails  are already removed.
%   Each test in `Tests` is a  term   `@(Test,Line)`,  which serves as a
%   unique identifier of the test.

:- det(runnable_tests/2).
runnable_tests(Spec, Unit:RunnableTests) :-
    unit_from_spec(Spec, Unit, Tests, Module, UnitOptions),
    (   option(blocked(Reason), UnitOptions)
    ->  info(plunit(blocked(unit(Unit, Reason)))),
        RunnableTests = []
    ;   \+ condition(Module, unit(Unit), UnitOptions)
    ->  RunnableTests = []
    ;   var(Tests)
    ->  findall(TestID,
                runnable_test(Unit, _Test, Module, TestID),
                RunnableTests)
    ;   flatten([Tests], TestList),
        findall(TestID,
                ( member(Test, TestList),
                  runnable_test(Unit,Test,Module, TestID)
                ),
                RunnableTests)
    ).

runnable_test(Unit, Name, Module, @(Test,Line)) :-
    current_test(Unit, Name, Line, _Body, TestOptions),
    (   option(blocked(Reason), TestOptions)
    ->  Test = blocked(Name, Reason)
    ;   condition(Module, test(Unit,Name,Line), TestOptions),
        Test = Name
    ).

unit_from_spec(Unit0:Tests0, Unit, Tests, Module, Options), atom(Unit0) =>
    Unit = Unit0,
    Tests = Tests0,
    (   current_unit(Unit, Module, _Supers, Options)
    ->  true
    ;   throw_error(existence_error(unit_test, Unit), _)
    ).
unit_from_spec(Unit0, Unit, _, Module, Options), atom(Unit0) =>
    Unit = Unit0,
    (   current_unit(Unit, Module, _Supers, Options)
    ->  true
    ;   throw_error(existence_error(unit_test, Unit), _)
    ).

%!  count_tests(+Units0, -Units, -Count) is det.
%
%   Count the number of tests to   run. A forall(Generator, Test) counts
%   as a single test. During the execution,   the  concrete tests of the
%   _forall_ are considered "sub tests".

count_tests(Units0, Units, Count) :-
    count_tests(Units0, Units, 0, Count).

count_tests([], T, C0, C) =>
    T = [],
    C = C0.
count_tests([_:[]|T0], T, C0, C) =>
    count_tests(T0, T, C0, C).
count_tests([Unit:Tests|T0], T, C0, C) =>
    partition(is_blocked, Tests, Blocked, Use),
    maplist(assert_blocked(Unit), Blocked),
    (   Use == []
    ->  count_tests(T0, T, C0, C)
    ;   length(Use, N),
        C1 is C0+N,
        T = [Unit:Use|T1],
        count_tests(T0, T1, C1, C)
    ).

is_blocked(@(blocked(_,_),_)) => true.
is_blocked(_) => fail.

assert_blocked(Unit, @(blocked(Test, Reason), Line)) =>
    assert(blocked(Unit, Test, Line, Reason)).

%!  run_unit(+Unit) is det.
%
%   Run a single test unit. Unit is a  term Unit:Tests, where Tests is a
%   list of tests to run.

run_unit(_Unit:[]) =>
    true.
run_unit(Unit:Tests) =>
    unit_module(Unit, Module),
    unit_options(Unit, UnitOptions),
    (   setup(Module, unit(Unit), UnitOptions)
    ->  begin_unit(Unit),
        call_time(run_unit_2(Unit, Tests), Time),
        test_summary(Unit, Summary),
	end_unit(Unit, Summary.put(time, Time)),
        cleanup(Module, UnitOptions)
    ;   job_info(end(unit(Unit, _{error:setup_failed})))
    ).

begin_unit(Unit) :-
    job_info(begin(unit(Unit))),
    job_feedback(informational, begin(Unit)).

end_unit(Unit, Summary) :-
    job_info(end(unit(Unit, Summary))),
    job_feedback(informational, end(Unit, Summary)).

run_unit_2(Unit, Tests) :-
    forall(member(Test, Tests),
	   run_test(Unit, Test)).


unit_options(Unit, Options) :-
    current_unit(Unit, _Module, _Supers, Options).


cleanup :-
    set_flag(plunit_test, 1),
    retractall(output_streams(_,_)),
    retractall(test_count(_)),
    retractall(passed(_, _, _, _, _)),
    retractall(failed(_, _, _, _, _)),
    retractall(timeout(_, _, _, _, _)),
    retractall(failed_assertion(_, _, _, _, _, _, _)),
    retractall(blocked(_, _, _, _)),
    retractall(fixme(_, _, _, _, _)),
    retractall(running(_,_,_,_,_)),
    retractall(forall_failures(_,_)).

cleanup_after_test :-
    (   current_test_flag(cleanup, true)
    ->  cleanup
    ;   true
    ).


%!  run_tests_in_files(+Files:list) is det.
%
%   Run all test-units that appear in the given Files.

run_tests_in_files(Files) :-
    findall(Unit, unit_in_files(Files, Unit), Units),
    (   Units == []
    ->  true
    ;   run_tests(Units)
    ).

unit_in_files(Files, Unit) :-
    is_list(Files),
    !,
    member(F, Files),
    absolute_file_name(F, Source,
		       [ file_type(prolog),
			 access(read),
			 file_errors(fail)
		       ]),
    unit_file(Unit, Source).


		 /*******************************
		 *         HOOKING MAKE/0       *
		 *******************************/

%!  make_run_tests(+Files)
%
%   Called indirectly from make/0 after Files have been reloaded.

make_run_tests(Files) :-
    current_test_flag(run, When),
    (   When == make
    ->  run_tests_in_files(Files)
    ;   When == make(all)
    ->  run_tests
    ;   true
    ).

		 /*******************************
		 *      ASSERTION HANDLING      *
		 *******************************/

:- if(swi).

:- dynamic prolog:assertion_failed/2.

setup_trap_assertions(Ref) :-
    asserta((prolog:assertion_failed(Reason, Goal) :-
		    test_assertion_failed(Reason, Goal)),
	    Ref).

cleanup_trap_assertions(Ref) :-
    erase(Ref).

test_assertion_failed(Reason, Goal) :-
    thread_self(Me),
    running(Unit, Test, Line, Progress, Me),
    (   catch(get_prolog_backtrace(10, Stack), _, fail),
	assertion_location(Stack, AssertLoc)
    ->  true
    ;   AssertLoc = unknown
    ),
    report_failed_assertion(Unit:Test, Line, AssertLoc,
			    Progress, Reason, Goal),
    assert_cyclic(failed_assertion(Unit, Test, Line, AssertLoc,
				   Progress, Reason, Goal)).

assertion_location(Stack, File:Line) :-
    append(_, [AssertFrame,CallerFrame|_], Stack),
    prolog_stack_frame_property(AssertFrame,
				predicate(prolog_debug:assertion/1)),
    !,
    prolog_stack_frame_property(CallerFrame, location(File:Line)).

report_failed_assertion(UnitTest, Line, AssertLoc,
			Progress, Reason, Goal) :-
    print_message(
	error,
	plunit(failed_assertion(UnitTest, Line, AssertLoc,
				Progress, Reason, Goal))).

:- else.

setup_trap_assertions(_).
cleanup_trap_assertions(_).

:- endif.


		 /*******************************
		 *         RUNNING A TEST       *
		 *******************************/

%!  run_test(+Unit, +Test) is det.
%
%   Run a single test.

run_test(Unit, @(Test,Line)) :-
    unit_module(Unit, Module),
    Module:'unit test'(Test, Line, TestOptions, Body),
    unit_options(Unit, UnitOptions),
    run_test(Unit, Test, Line, UnitOptions, TestOptions, Body).

%!  run_test(+Unit, +Name, +Line, +UnitOptions, +Options, +Body)
%
%   Deals with forall(Generator, Test)

run_test(Unit, Name, Line, UnitOptions, Options, Body) :-
    option(forall(Generator), Options),
    !,
    unit_module(Unit, Module),
    term_variables(Generator, Vars),
    start_test(Unit, @(Name,Line), Nth),
    State = state(0),
    call_time(forall(Module:Generator,            % may become concurrent
                     (   incr_forall(State, I),
                         run_test_once6(Unit, Name, forall(Vars, Nth-I), Line,
                                        UnitOptions, Options, Body)
                     )),
                     Time),
    arg(1, State, Generated),
    progress(Unit:Name, Nth, forall(end, Nth, Generated), Time).
run_test(Unit, Name, Line, UnitOptions, Options, Body) :-
    start_test(Unit, @(Name,Line), Nth),
    run_test_once6(Unit, Name, Nth, Line, UnitOptions, Options, Body).

start_test(_Unit, _TestID, Nth) :-
    flag(plunit_test, Nth, Nth+1).

incr_forall(State, I) :-
    arg(1, State, I0),
    I is I0+1,
    nb_setarg(1, State, I).

%!  run_test_once6(+Unit, +Name, +Progress, +Line, +UnitOptions,
%!                 +Options, +Body)
%
%   Inherit the `timeout` and `occurs_check` option (Global -> Unit -> Test).

run_test_once6(Unit, Name, Progress, Line, UnitOptions, Options, Body) :-
    current_test_flag(timeout, DefTimeOut),
    current_test_flag(occurs_check, DefOccurs),
    inherit_option(timeout,      Options,  [UnitOptions], DefTimeOut, Options1),
    inherit_option(occurs_check, Options1, [UnitOptions], DefOccurs, Options2),
    run_test_once(Unit, Name, Progress, Line, Options2, Body).

inherit_option(Name, Options0, Chain, Default, Options) :-
    Term =.. [Name,_Value],
    (   option(Term, Options0)
    ->  Options = Options0
    ;   member(Opts, Chain),
        option(Term, Opts)
    ->  Options = [Term|Options0]
    ;   Default == (-)
    ->  Options = Options0
    ;   Opt =.. [Name,Default],
	Options = [Opt|Options0]
    ).

%!  run_test_once(+Unit, +Name, Progress, +Line, +Options, +Body)
%
%   Deal with occurs_check, i.e., running the  test multiple times with different
%   unification settings wrt. the occurs check.

run_test_once(Unit, Name, Progress, Line, Options, Body) :-
    option(occurs_check(Occurs), Options),
    !,
    begin_test(Unit, Name, Line, Progress),
    current_prolog_flag(occurs_check, Old),
    setup_call_cleanup(
	set_prolog_flag(occurs_check, Occurs),
	capture_output(run_test_6(Unit, Name, Line, Options, Body, Result),
		       Output),
	set_prolog_flag(occurs_check, Old)),
    end_test(Unit, Name, Line, Progress),
    report_result(Result, Progress, Output, Options).
run_test_once(Unit, Name, Progress, Line, Options, Body) :-
    begin_test(Unit, Name, Line, Progress),
    capture_output(run_test_6(Unit, Name, Line, Options, Body, Result),
		   Output),
    end_test(Unit, Name, Line, Progress),
    report_result(Result, Progress, Output, Options).

%!  report_result(+Result, +Progress, +Output, +Options) is det.

:- det(report_result/4).
report_result(failure(Unit, Name, Line, How, Time),
	      Progress, Output, Options) :-
    !,
    failure(Unit, Name, Progress, Line, How, Time, Output, Options).
report_result(success(Unit, Name, Line, Determinism, Time),
	      Progress, Output, Options) :-
    !,
    success(Unit, Name, Progress, Line, Determinism, Time, Output, Options).
report_result(setup_failed(_Unit, _Name, _Line),
	      _Progress, _Output, _Options).

%!  run_test_6(+Unit, +Name, +Line, +Options, :Body, -Result) is det.
%
%   6th step  of the  tests.  Deals  with tests  that must  be ignored
%   (blocked, conditions fails), setup and cleanup at the test level.
%   Result is one of:
%
%     - failure(Unit, Name, Line, How, Time)
%       How is one of:
%       - succeeded
%       - Exception
%       - time_limit_exceeded(Limit)
%       - cmp_error(Cmp, E)
%       - wrong_answer(Cmp)
%       - failed
%       - no_exception
%       - wrong_error(Expect, E)
%       - wrong_answer(Expected, Bindings)
%     - success(Unit, Name, Line, Determinism, Time)
%     - setup_failed(Unit, Name, Line)

run_test_6(Unit, Name, Line, Options, Body, Result) :-
    option(setup(_Setup), Options),
    !,
    (   unit_module(Unit, Module),
        setup(Module, test(Unit,Name,Line), Options)
    ->  run_test_7(Unit, Name, Line, Options, Body, Result),
        cleanup(Module, Options)
    ;   Result = setup_failed(Unit, Name, Line)
    ).
run_test_6(Unit, Name, Line, Options, Body, Result) :-
    unit_module(Unit, Module),
    run_test_7(Unit, Name, Line, Options, Body, Result),
    cleanup(Module, Options).

%!  run_test_7(+Unit, +Name, +Line, +Options, :Body, -Result) is det.
%
%   This step  deals with the expected  outcome of the test.   It runs
%   the  actual test  and then  compares  the result  to the  outcome.
%   There are  two main categories:  dealing with a single  result and
%   all results.

run_test_7(Unit, Name, Line, Options, Body, Result) :-
    option(true(Cmp), Options),			   % expected success
    !,
    unit_module(Unit, Module),
    call_time(reify_tmo(call_det(Module:Body, Det), Result0, Options), Time),
    (   Result0 == true
    ->  cmp_true(Cmp, Module, CmpResult),
	(   CmpResult == []
	->  Result = success(Unit, Name, Line, Det, Time)
	;   Result = failure(Unit, Name, Line, CmpResult, Time)
	)
    ;   Result0 == false
    ->  Result = failure(Unit, Name, Line, failed, Time)
    ;   Result0 = throw(E2)
    ->  Result = failure(Unit, Name, Line, throw(E2), Time)
    ).
run_test_7(Unit, Name, Line, Options, Body, Result) :-
    option(fail, Options),                         % expected failure
    !,
    unit_module(Unit, Module),
    call_time(reify_tmo(Module:Body, Result0, Options), Time),
    (   Result0 == true
    ->  Result = failure(Unit, Name, Line, succeeded, Time)
    ;   Result0 == false
    ->  Result = success(Unit, Name, Line, true, Time)
    ;   Result0 = throw(E)
    ->  Result = failure(Unit, Name, Line, throw(E), Time)
    ).
run_test_7(Unit, Name, Line, Options, Body, Result) :-
    option(throws(Expect), Options),		   % Expected error
    !,
    unit_module(Unit, Module),
    call_time(reify_tmo(Module:Body, Result0, Options), Time),
    (   Result0 == true
    ->  Result = failure(Unit, Name, Line, no_exception, Time)
    ;   Result0 == false
    ->  Result = failure(Unit, Name, Line, failed, Time)
    ;   Result0 = throw(E)
    ->  (   match_error(Expect, E)
        ->  Result = success(Unit, Name, Line, true, Time)
        ;   Result = failure(Unit, Name, Line, wrong_error(Expect, E), Time)
        )
    ).
run_test_7(Unit, Name, Line, Options, Body, Result) :-
    option(all(Answer), Options),                  % all(Bindings)
    !,
    nondet_test(all(Answer), Unit, Name, Line, Options, Body, Result).
run_test_7(Unit, Name, Line, Options, Body, Result) :-
    option(set(Answer), Options),                  % set(Bindings)
    !,
    nondet_test(set(Answer), Unit, Name, Line, Options, Body, Result).

%!  non_det_test(+Expected, +Unit, +Name, +Line, +Options, +Body, -Result)
%
%   Run tests on non-deterministic predicates.

nondet_test(Expected, Unit, Name, Line, Options, Body, Result) :-
    unit_module(Unit, Module),
    result_vars(Expected, Vars),
    (   call_time(reify_tmo(findall(Vars, Module:Body, Bindings),
                            Result0, Options), Time)
    ->  (   Result0 == true
        ->  (   nondet_compare(Expected, Bindings, Unit, Name, Line)
            ->  Result = success(Unit, Name, Line, true, Time)
            ;   Result = failure(Unit, Name, Line,
				 [wrong_answer(Expected, Bindings)], Time)
            )
        ;   Result0 = throw(E)
        ->  Result = failure(Unit, Name, Line, throw(E), Time)
        )
    ).

cmp_true([], _, L) =>
    L = [].
cmp_true([Cmp|T], Module, L) =>
    E = error(Formal,_),
    cmp_goal(Cmp, Goal),
    (   catch(Module:Goal, E, true)
    ->  (   var(Formal)
	->  cmp_true(T, Module, L)
	;   L = [cmp_error(Cmp,E)|L1],
	    cmp_true(T, Module, L1)
	)
    ;   L = [wrong_answer(Cmp)|L1],
	cmp_true(T, Module, L1)
    ).

cmp_goal(cmp(_Var, Expr), Goal) => Goal = Expr.
cmp_goal(Expr, Goal) => Goal = Expr.


%!  result_vars(+Expected, -Vars) is det.
%
%   Create a term v(V1, ...) containing all variables at the left
%   side of the comparison operator on Expected.

result_vars(Expected, Vars) :-
    arg(1, Expected, CmpOp),
    arg(1, CmpOp, Vars).

%!  nondet_compare(+Expected, +Bindings, +Unit, +Name, +Line) is semidet.
%
%   Compare list/set results for non-deterministic predicates.
%
%   @tbd    Properly report errors
%   @bug    Sort should deal with equivalence on the comparison
%           operator.

nondet_compare(all(Cmp), Bindings, _Unit, _Name, _Line) :-
    cmp(Cmp, _Vars, Op, Values),
    cmp_list(Values, Bindings, Op).
nondet_compare(set(Cmp), Bindings0, _Unit, _Name, _Line) :-
    cmp(Cmp, _Vars, Op, Values0),
    sort(Bindings0, Bindings),
    sort(Values0, Values),
    cmp_list(Values, Bindings, Op).

cmp_list([], [], _Op).
cmp_list([E0|ET], [V0|VT], Op) :-
    call(Op, E0, V0),
    cmp_list(ET, VT, Op).

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

cmp(Var  == Value, Var,  ==, Value).
cmp(Var =:= Value, Var, =:=, Value).
cmp(Var  =  Value, Var,  =,  Value).
:- if(swi).
cmp(Var =@= Value, Var, =@=, Value).
:- else.
:- if(sicstus).
cmp(Var =@= Value, Var, variant, Value). % variant/2 is the same =@=
:- endif.
:- endif.


%!  call_det(:Goal, -Det) is nondet.
%
%   True if Goal succeeded.  Det is unified to =true= if Goal left
%   no choicepoints and =false= otherwise.

:- if((swi;sicstus)).
call_det(Goal, Det) :-
    call_cleanup(Goal,Det0=true),
    ( var(Det0) -> Det = false ; Det = true ).
:- else.
call_det(Goal, true) :-
    call(Goal).
:- endif.

%!  match_error(+Expected, +Received) is semidet.
%
%   True if the Received errors matches the expected error. Matching
%   is based on subsumes_term/2.

match_error(Expect, Rec) :-
    subsumes_term(Expect, Rec).

%!  setup(+Module, +Context, +Options) is semidet.
%
%   Call the setup handler and  fail  if   it  cannot  run  for some
%   reason. The condition handler is  similar,   but  failing is not
%   considered an error.  Context is one of
%
%    - unit(Unit)
%      If it is the setup handler for a unit
%    - test(Unit,Name,Line)
%      If it is the setup handler for a test

setup(Module, Context, Options) :-
    option(setup(Setup), Options),
    !,
    capture_output(reify(call_ex(Module, Setup), Result), Output),
    (   Result == true
    ->  true
    ;   print_message(error,
		      plunit(error(setup, Context, Output, Result))),
	fail
    ).
setup(_,_,_).

%!  condition(+Module, +Context, +Options) is semidet.
%
%   Evaluate the test or test unit condition.

condition(Module, Context, Options) :-
    option(condition(Cond), Options),
    !,
    capture_output(reify(call_ex(Module, Cond), Result), Output),
    (   Result == true
    ->  true
    ;   Result == false
    ->  fail
    ;   print_message(error,
		      plunit(error(condition, Context, Output, Result))),
	fail
    ).
condition(_, _, _).


%!  call_ex(+Module, +Goal)
%
%   Call Goal in Module after applying goal expansion.

call_ex(Module, Goal) :-
    Module:(expand_goal(Goal, GoalEx),
	    GoalEx).

%!  cleanup(+Module, +Options) is det.
%
%   Call the cleanup handler and succeed.   Failure  or error of the
%   cleanup handler is reported, but tests continue normally.

cleanup(Module, Options) :-
    option(cleanup(Cleanup), Options, true),
    (   catch(call_ex(Module, Cleanup), E, true)
    ->  (   var(E)
	->  true
	;   print_message(warning, E)
	)
    ;   print_message(warning, goal_failed(Cleanup, '(cleanup handler)'))
    ).

success(Unit, Name, Progress, Line, Det, Time, _Output, Options) :-
    memberchk(fixme(Reason), Options),
    !,
    (   (   Det == true
	;   memberchk(nondet, Options)
	)
    ->  progress(Unit:Name, Progress, fixme(passed), Time),
	Ok = passed
    ;   progress(Unit:Name, Progress, fixme(nondet), Time),
	Ok = nondet
    ),
    flush_output(user_error),
    assert(fixme(Unit, Name, Line, Reason, Ok)).
success(Unit, Name, Progress, Line, _, Time, Output, Options) :-
    failed_assertion(Unit, Name, Line, _,Progress,_,_),
    !,
    failure(Unit, Name, Progress, Line, assertion, Time, Output, Options).
success(Unit, Name, Progress, Line, _, Time, Output, Options) :-
    Output = true-_,
    !,
    failure(Unit, Name, Progress, Line, message, Time, Output, Options).
success(Unit, Name, Progress, Line, Det, Time, _Output, Options) :-
    assert(passed(Unit, Name, Line, Det, Time)),
    (   (   Det == true
	;   memberchk(nondet, Options)
	)
    ->  progress(Unit:Name, Progress, passed, Time)
    ;   unit_file(Unit, File),
	print_message(warning, plunit(nondet(File, Line, Name)))
    ).

%!  failure(+Unit, +Name, +Progress, +Line,
%!          +How, +Time, +Output, +Options) is det.
%
%   Test failed.  Report the error.

failure(Unit, Name, Progress, Line, _, Time, _Output, Options),
  memberchk(fixme(Reason), Options) =>
    assert(fixme(Unit, Name, Line, Reason, failed)),
    progress(Unit:Name, Progress, fixme(failed), Time).
failure(Unit, Name, Progress, Line, time_limit_exceeded(Limit), Time,
	Output, Options) =>
    assert_cyclic(timeout(Unit, Name, Line, Limit, Time)),
    progress(Unit:Name, Progress, timeout(Limit), Time),
    report_failure(Unit, Name, Progress, Line, timeout(Limit), Time, Output, Options).
failure(Unit, Name, Progress, Line, E, Time, Output, Options) =>
    assert_cyclic(failed(Unit, Name, Line, E, Time)),
    progress(Unit:Name, Progress, failed, Time),
    report_failure(Unit, Name, Progress, Line, E, Time, Output, Options).

%!  assert_cyclic(+Term) is det.
%
%   Assert  a  possibly  cyclic  unit   clause.  Current  SWI-Prolog
%   assert/1 does not handle cyclic terms,  so we emulate this using
%   the recorded database.
%
%   @tbd    Implement cycle-safe assert and remove this.

:- if(swi).
assert_cyclic(Term) :-
    acyclic_term(Term),
    !,
    assert(Term).
assert_cyclic(Term) :-
    Term =.. [Functor|Args],
    recorda(cyclic, Args, Id),
    functor(Term, _, Arity),
    length(NewArgs, Arity),
    Head =.. [Functor|NewArgs],
    assert((Head :- recorded(_, Var, Id), Var = NewArgs)).
:- else.
:- if(sicstus).
:- endif.
assert_cyclic(Term) :-
    assert(Term).
:- endif.


		 /*******************************
		 *             JOBS             *
		 *******************************/

:- if(current_prolog_flag(threads, true)).

:- dynamic
       job_data/2,		% Queue, Threads
       scheduled_unit/1.

schedule_unit(_:[]) :-
    !.
schedule_unit(UnitAndTests) :-
    UnitAndTests = Unit:_Tests,
    job_data(Queue, _),
    !,
    assertz(scheduled_unit(Unit)),
    thread_send_message(Queue, unit(UnitAndTests)).
schedule_unit(Unit) :-
    run_unit(Unit).

%!  setup_jobs(+Count) is det.
%
%   Setup threads for concurrent testing.

setup_jobs(Count) :-
    (   current_test_flag(jobs, Jobs0),
	integer(Jobs0)
    ->  true
    ;   current_prolog_flag(cpu_count, Jobs0)
    ),
    Jobs is min(Count, Jobs0),
    Jobs > 1,
    !,
    message_queue_create(Q, [alias(plunit_jobs)]),
    length(TIDs, Jobs),
    foldl(create_plunit_job(Q), TIDs, 1, _),
    asserta(job_data(Q, TIDs)),
    job_feedback(informational, jobs(Jobs)).
setup_jobs(_) :-
    job_feedback(informational, jobs(1)).

create_plunit_job(Q, TID, N, N1) :-
    N1 is N + 1,
    atom_concat(plunit_job_, N, Alias),
    thread_create(plunit_job(Q), TID, [alias(Alias)]).

plunit_job(Queue) :-
    repeat,
    (   catch(thread_get_message(Queue, Job,
				 [ timeout(10)
				 ]),
	      error(_,_), fail)
    ->  job(Job),
	fail
    ;   !
    ).

job(unit(Unit:Tests)) =>
    run_unit(Unit:Tests).
job(test(Unit, Test)) =>
    run_test(Unit, Test).

cleanup_jobs :-
    retract(job_data(Queue, TIDSs)),
    !,
    message_queue_destroy(Queue),
    maplist(thread_join, TIDSs).
cleanup_jobs.

%!  job_wait(?Unit) is det.
%
%   Wait for all test jobs to finish.

job_wait(Unit) :-
    thread_wait(\+ scheduled_unit(Unit),
		[ wait_preds([scheduled_unit/1]),
		  timeout(1)
		]),
    !.
job_wait(Unit) :-
    job_data(_Queue, TIDs),
    member(TID, TIDs),
    thread_property(TID, status(running)),
    !,
    job_wait(Unit).
job_wait(_).


job_info(begin(unit(Unit))) =>
    print_message(silent, plunit(begin(Unit))).
job_info(end(unit(Unit, Summary))) =>
    retractall(scheduled_unit(Unit)),
    print_message(silent, plunit(end(Unit, Summary))).

:- else.			% No jobs

schedule_unit(Unit) :-
    run_unit(Unit).

setup_jobs(_) :-
    print_message(silent, plunit(jobs(1))).
cleanup_jobs.
job_wait(_).
job_info(_).

:- endif.



		 /*******************************
		 *            REPORTING         *
		 *******************************/

%!  begin_test(+Unit, +Test, +Line, +Progress) is det.
%!  end_test(+Unit, +Test, +Line, +Progress) is det.
%
%   Maintain running/5 and report a test has started/is ended using
%   a =silent= message:
%
%       * plunit(begin(Unit:Test, File:Line, Progress))
%       * plunit(end(Unit:Test, File:Line, Progress))
%
%   @see message_hook/3 for intercepting these messages

begin_test(Unit, Test, Line, Progress) :-
    thread_self(Me),
    assert(running(Unit, Test, Line, Progress, Me)),
    unit_file(Unit, File),
    test_count(Total),
    job_feedback(information, begin(Unit:Test, File:Line, Progress/Total)).

end_test(Unit, Test, Line, Progress) :-
    thread_self(Me),
    retractall(running(_,_,_,_,Me)),
    unit_file(Unit, File),
    test_count(Total),
    job_feedback(information, end(Unit:Test, File:Line, Progress/Total)).

%!  running_tests is det.
%
%   Print the currently running test.

running_tests :-
    running_tests(Running),
    print_message(informational, plunit(running(Running))).

running_tests(Running) :-
    test_count(Total),
    findall(running(Unit:Test, File:Line, Progress/Total, Thread),
	    (   running(Unit, Test, Line, Progress, Thread),
		unit_file(Unit, File)
	    ), Running).


%!  current_test(?Unit, ?Test, ?Line, ?Body, ?Options) is nondet.
%
%   True when a test with the specified properties is loaded.

current_test(Unit, Test, Line, Body, Options) :-
    current_unit(Unit, Module, _Supers, _UnitOptions),
    Module:'unit test'(Test, Line, Options, Body).

%!  current_test_unit(?Unit, ?Options) is nondet.
%
%   True when a Unit is a current unit test declared with Options.

current_test_unit(Unit, UnitOptions) :-
    current_unit(Unit, _Module, _Supers, UnitOptions).


count(Goal, Count) :-
    aggregate_all(count, Goal, Count).

%!  test_summary(?Unit, -Summary) is det.
%
%   True when Summary is a dict that reports the main statistics
%   about the executed tests.

test_summary(Unit, Summary) :-
    count(failed(Unit, _0Test, _0Line, _Reason, _0Time), Failed),
    count(timeout(Unit, _0Test, _0Line, _Limit, _0Time), Timeout),
    count(passed(Unit, _0Test, _0Line, _Det, _0Time), Passed),
    count(blocked(Unit, _0Test, _0Line, _0Reason), Blocked),
    count(fixme(Unit, _0Test, _0Line, _0Reason, _0How), Fixme),
    test_count(Total),
    Summary = plunit{total:Total,
		     passed:Passed,
		     failed:Failed,
		     timeout:Timeout,
		     blocked:Blocked,
		     fixme:Fixme}.

test_summary_passed(Summary) :-
    _{failed: 0} :< Summary.

%!  report(+Time, +Options) is det.
%
%   Print a summary of the tests that ran.

report(Time, _Options) :-
    test_summary(_, Summary),
    print_message(silent, plunit(Summary)),
    _{ passed:Passed,
       failed:Failed,
       timeout:Timeout,
       blocked:Blocked,
       fixme:Fixme
     } :< Summary,
    (   Passed+Failed+Timeout+Blocked+Fixme =:= 0
    ->  info(plunit(no_tests))
    ;   Failed+Timeout =:= 0
    ->  report_blocked(Blocked),
	report_fixme,
        test_count(Total),
	info(plunit(all_passed(Total, Passed, Time)))
    ;   report_blocked(Blocked),
	report_fixme,
	report_failed(Failed),
	report_timeout(Timeout),
	info(plunit(passed(Passed))),
        info(plunit(total_time(Time)))
    ).

report_blocked(0) =>
    true.
report_blocked(Blocked) =>
    findall(blocked(Unit:Name, File:Line, Reason),
	    ( blocked(Unit, Name, Line, Reason),
	      unit_file(Unit, File)
	    ),
	    BlockedTests),
    info(plunit(blocked(Blocked, BlockedTests))).

report_failed(Failed) :-
    print_message(error, plunit(failed(Failed))).

report_timeout(Count) :-
    print_message(warning, plunit(timeout(Count))).

report_fixme :-
    report_fixme(_,_,_).

report_fixme(TuplesF, TuplesP, TuplesN) :-
    fixme(failed, TuplesF, Failed),
    fixme(passed, TuplesP, Passed),
    fixme(nondet, TuplesN, Nondet),
    print_message(informational, plunit(fixme(Failed, Passed, Nondet))).


fixme(How, Tuples, Count) :-
    findall(fixme(Unit, Name, Line, Reason, How),
	    fixme(Unit, Name, Line, Reason, How), Tuples),
    length(Tuples, Count).

report_failure(Unit, Name, Progress, Line, Error,
	       Time, Output, _Options) =>
    test_count(Total),
    job_feedback(error, failed(Unit:Name, Progress/Total, Line,
			       Error, Time, Output)).


%!  test_report(+What) is det.
%
%   Produce reports on test  results  after   the  run.  Currently  only
%   supports `fixme` for What.

test_report(fixme) :-
    !,
    report_fixme(TuplesF, TuplesP, TuplesN),
    append([TuplesF, TuplesP, TuplesN], Tuples),
    print_message(informational, plunit(fixme(Tuples))).
test_report(What) :-
    throw_error(domain_error(report_class, What), _).


		 /*******************************
		 *             INFO             *
		 *******************************/

%!  unit_file(+Unit, -File) is det.
%!  unit_file(?Unit, ?File) is nondet.
%
%   True when the test unit Unit is defined in File.

unit_file(Unit, File), nonvar(Unit) =>
    unit_file_(Unit, File),
    !.
unit_file(Unit, File) =>
    unit_file_(Unit, File).

unit_file_(Unit, File) :-
    current_unit(Unit, Module, _Context, _Options),
    module_property(Module, file(File)).
unit_file_(Unit, PlFile) :-
    test_file_for(TestFile, PlFile),
    module_property(Module, file(TestFile)),
    current_unit(Unit, Module, _Context, _Options).


		 /*******************************
		 *             FILES            *
		 *******************************/

%!  load_test_files(+Options) is det.
%
%   Load .plt test-files related  to   loaded  source-files.  Options is
%   currently ignored.

load_test_files(_Options) :-
    State = state(0,0),
    (   source_file(File),
	file_name_extension(Base, Old, File),
	Old \== plt,
	file_name_extension(Base, plt, TestFile),
	exists_file(TestFile),
        inc_arg(1, State),
	(   test_file_for(TestFile, File)
	->  true
	;   load_files(TestFile,
		       [ if(changed),
			 imports([])
		       ]),
            inc_arg(2, State),
	    asserta(test_file_for(TestFile, File))
	),
        fail
    ;   State = state(Total, Loaded),
        print_message(informational, plunit(test_files(Total, Loaded)))
    ).

inc_arg(Arg, State) :-
    arg(Arg, State, N0),
    N is N0+1,
    nb_setarg(Arg, State, N).


		 /*******************************
		 *           MESSAGES           *
		 *******************************/

%!  info(+Term)
%
%   Runs print_message(Level, Term), where Level is   one of `silent` or
%   `informational` (default).

info(Term) :-
    message_level(Level),
    print_message(Level, Term).

%!  progress(+UnitTest, +Progress, +Result, +Time) is det.
%
%   Test Unit:Name completed in Time. Result is the result and is one of
%
%     - passed
%     - failed
%     - assertion
%     - nondet
%     - fixme(passed)
%     - fixme(nondet)
%     - fixme(failed)
%     - forall(end, Nth, FTotal)
%       Pseudo result for completion of a forall(Gen,Test) set.  Mapped
%       to forall(FTotal, FFailed)

progress(UnitTest, _Progress, forall(end, Nth, FTotal), Time) =>
    (   retract(forall_failures(Nth, FFailed))
    ->  true
    ;   FFailed = 0
    ),
    test_count(Total),
    job_feedback(information, progress(UnitTest, forall(FTotal,FFailed), Nth/Total, Time)).
progress(UnitTest, Progress, Result, Time), Progress = forall(_Vars, Nth-_I) =>
    with_mutex(plunit_forall_counter,
               update_forall_failures(Nth, Result)),
    test_count(Total),
    job_feedback(information, progress(UnitTest, Result, Progress/Total, Time)).
progress(UnitTest, Progress, Result, Time) =>
    test_count(Total),
    job_feedback(information, progress(UnitTest, Result, Progress/Total, Time)).

update_forall_failures(_Nth, passed) =>
    true.
update_forall_failures(Nth, _) =>
    (   retract(forall_failures(Nth, Failed0))
    ->  true
    ;   Failed0 = 0
    ),
    Failed is Failed0+1,
    asserta(forall_failures(Nth, Failed)).

message_level(Level) :-
    (   current_test_flag(silent, true)
    ->  Level = silent
    ;   Level = informational
    ).

locationprefix(File:Line) -->
    !,
    [ url(File:Line), ':'-[], nl, '    ' ].
locationprefix(test(Unit,_Test,Line)) -->
    !,
    { unit_file(Unit, File) },
    locationprefix(File:Line).
locationprefix(unit(Unit)) -->
    !,
    [ 'PL-Unit: unit ~w: '-[Unit] ].
locationprefix(FileLine) -->
    { throw_error(type_error(locationprefix,FileLine), _) }.

:- discontiguous
    message//1.
:- '$hide'(message//1).

message(error(context_error(plunit_close(Name, -)), _)) -->
    [ 'PL-Unit: cannot close unit ~w: no open unit'-[Name] ].
message(error(context_error(plunit_close(Name, Start)), _)) -->
    [ 'PL-Unit: cannot close unit ~w: current unit is ~w'-[Name, Start] ].
message(plunit(nondet(File, Line, Name))) -->
    locationprefix(File:Line),
    [ 'PL-Unit: Test ~w: Test succeeded with choicepoint'- [Name] ].
message(error(plunit(incompatible_options, Tests), _)) -->
    [ 'PL-Unit: incompatible test-options: ~p'-[Tests] ].
message(plunit(sto(true))) -->
    [ 'Option sto(true) is ignored.  See `occurs_check` option.'-[] ].
message(plunit(test_files(Total, Loaded))) -->
    [ 'Found ~D .plt test files, loaded ~D'-[Total, Loaded] ].

					% Unit start/end
message(plunit(jobs(1))) -->
    !.
message(plunit(jobs(N))) -->
    [ 'Testing with ~D parallel jobs'-[N] ].
message(plunit(begin(_Unit))) -->
    { tty_feedback },
    !.
message(plunit(begin(Unit))) -->
    [ 'Start unit: ~w~n'-[Unit], flush ].
message(plunit(end(_Unit, _Summary))) -->
    { tty_feedback },
    !.
message(plunit(end(Unit, Summary))) -->
    (   {test_summary_passed(Summary)}
    ->  [ 'End unit ~w: passed (~3f sec CPU)'-[Unit, Summary.time.cpu] ]
    ;   [ ansi(error, 'End unit ~w: **FAILED (~3f sec CPU)', [Unit, Summary.time.cpu]) ]
    ).
message(plunit(blocked(unit(Unit, Reason)))) -->
    [ 'PL-Unit: ~w blocked: ~w'-[Unit, Reason] ].
message(plunit(running([]))) -->
    !,
    [ 'PL-Unit: no tests running' ].
message(plunit(running([One]))) -->
    !,
    [ 'PL-Unit: running ' ],
    running(One).
message(plunit(running(More))) -->
    !,
    [ 'PL-Unit: running tests:', nl ],
    running(More).
message(plunit(fixme([]))) --> !.
message(plunit(fixme(Tuples))) -->
    !,
    fixme_message(Tuples).
message(plunit(total_time(Time))) -->
    [ 'Test run completed'-[] ],
    test_time(Time).

					% Blocked tests
message(plunit(blocked(1, Tests))) -->
    !,
    [ 'one test is blocked'-[] ],
    blocked_tests(Tests).
message(plunit(blocked(N, Tests))) -->
    [ '~D tests are blocked'-[N] ],
    blocked_tests(Tests).

blocked_tests(Tests) -->
    { current_test_flag(show_blocked, true) },
    !,
    [':'-[]],
    list_blocked(Tests).
blocked_tests(_) -->
    [ ' (use run_tests/2 with ', ansi(code, 'show_blocked(true)', []),
      ' for details)'-[]
    ].

list_blocked([]) --> !.
list_blocked([blocked(Unit:Test, Pos, Reason)|T]) -->
    [nl],
    locationprefix(Pos),
    test_name(Unit:Test, -),
    [ ': ~w'-[Reason] ],
    list_blocked(T).

					% fail/success
message(plunit(no_tests)) -->
    !,
    [ 'No tests to run' ].
message(plunit(all_passed(1, 1, Time))) -->
    !,
    [ 'test passed' ],
    test_time(Time).
message(plunit(all_passed(Total, Total, Time))) -->
    !,
    [ 'All ~D tests passed'-[Total] ],
    test_time(Time).
message(plunit(all_passed(Total, Count, Time))) -->
    !,
    { SubTests is Count-Total },
    [ 'All ~D (+~D sub-tests) tests passed'- [Total, SubTests] ],
    test_time(Time).

test_time(Time) -->
    { var(Time) }, !.
test_time(Time) -->
    [ ' in ~3f seconds (~3f cpu)'-[Time.wall, Time.cpu] ].

message(plunit(passed(Count))) -->
    !,
    [ '~D tests passed'-[Count] ].
message(plunit(failed(0))) -->
    !,
    [].
message(plunit(failed(1))) -->
    !,
    [ '1 test failed'-[] ].
message(plunit(failed(N))) -->
    [ '~D tests failed'-[N] ].
message(plunit(timeout(0))) -->
    !,
    [].
message(plunit(timeout(N))) -->
    [ '~D tests timed out'-[N] ].
message(plunit(fixme(0,0,0))) -->
    [].
message(plunit(fixme(Failed,0,0))) -->
    !,
    [ 'all ~D tests flagged FIXME failed'-[Failed] ].
message(plunit(fixme(Failed,Passed,0))) -->
    [ 'FIXME: ~D failed; ~D passed'-[Failed, Passed] ].
message(plunit(fixme(Failed,Passed,Nondet))) -->
    { TotalPassed is Passed+Nondet },
    [ 'FIXME: ~D failed; ~D passed; (~D nondet)'-
      [Failed, TotalPassed, Nondet] ].

message(plunit(begin(Unit:Test, _Location, Progress))) -->
    { tty_columns(SummaryWidth, _Margin),
      test_name_summary(Unit:Test, SummaryWidth, NameS),
      progress_string(Progress, ProgressS)
    },
    (   { tty_feedback,
	  tty_clear_to_eol(CE)
	}
    ->  [ at_same_line, '\r[~w] ~w ..~w'-[ProgressS, NameS,
					     CE], flush ]
    ;   { jobs(_) }
    ->  [ '[~w] ~w ..'-[ProgressS, NameS] ]
    ;   [ '[~w] ~w ..'-[ProgressS, NameS], flush ]
    ).
message(plunit(end(_UnitTest, _Location, _Progress))) -->
    [].
message(plunit(progress(_UnitTest, Status, _Progress, _Time))) -->
    { Status = forall(_,_)
    ; Status == assertion
    },
    !.
message(plunit(progress(Unit:Test, Status, Progress, Time))) -->
    { jobs(_),
      !,
      tty_columns(SummaryWidth, Margin),
      test_name_summary(Unit:Test, SummaryWidth, NameS),
      progress_string(Progress, ProgressS),
      progress_tag(Status, Tag, _Keep, Style)
    },
    [ ansi(Style, '[~w] ~w ~`.t ~w (~3f sec)~*|',
	   [ProgressS, NameS, Tag, Time.wall, Margin]) ].
message(plunit(progress(_UnitTest, Status, _Progress, Time))) -->
    { tty_columns(_SummaryWidth, Margin),
      progress_tag(Status, Tag, _Keep, Style)
    },
    [ at_same_line, ansi(Style, '~`.t ~w (~3f sec)~*|',
			 [Tag, Time.wall, Margin]) ],
    (   { tty_feedback }
    ->  [flush]
    ;   []
    ).
message(plunit(failed(Unit:Test, Progress, Line, Failure, _Time, Output))) -->
    { unit_file(Unit, File) },
    locationprefix(File:Line),
    test_name(Unit:Test, Progress),
    [': '-[] ],
    failure(Failure),
    test_output(Output).
message(plunit(timeout(Unit:Test, Progress, Line, Limit, Output))) -->
    { unit_file(Unit, File) },
    locationprefix(File:Line),
    test_name(Unit:Test, Progress),
    [': '-[] ],
    timeout(Limit),
    test_output(Output).
:- if(swi).
message(plunit(failed_assertion(Unit:Test, Line, AssertLoc,
				Progress, Reason, Goal))) -->
    { unit_file(Unit, File) },
    locationprefix(File:Line),
    test_name(Unit:Test, Progress),
    [ ': assertion'-[] ],
    assertion_location(AssertLoc, File),
    assertion_reason(Reason), ['\n\t'],
    assertion_goal(Unit, Goal).

assertion_location(File:Line, File) -->
    [ ' at line ~w'-[Line] ].
assertion_location(File:Line, _) -->
    [ ' at ', url(File:Line) ].
assertion_location(unknown, _) -->
    [].

assertion_reason(fail) -->
    !,
    [ ' failed'-[] ].
assertion_reason(Error) -->
    { message_to_string(Error, String) },
    [ ' raised "~w"'-[String] ].

assertion_goal(Unit, Goal) -->
    { unit_module(Unit, Module),
      unqualify(Goal, Module, Plain)
    },
    [ 'Assertion: ~p'-[Plain] ].

unqualify(Var, _, Var) :-
    var(Var),
    !.
unqualify(M:Goal, Unit, Goal) :-
    nonvar(M),
    unit_module(Unit, M),
    !.
unqualify(M:Goal, _, Goal) :-
    callable(Goal),
    predicate_property(M:Goal, imported_from(system)),
    !.
unqualify(Goal, _, Goal).

test_output(Msgs-String) -->
    { nonvar(Msgs) },
    !,
    test_output(String).
test_output("") --> [].
test_output(Output) -->
    [ ansi(code, '~N~s', [Output]) ].

:- endif.
					% Setup/condition errors
message(plunit(error(Where, Context, _Output, throw(Exception)))) -->
    locationprefix(Context),
    { message_to_string(Exception, String) },
    [ 'error in ~w: ~w'-[Where, String] ].
message(plunit(error(Where, Context, _Output, false))) -->
    locationprefix(Context),
    [ 'setup failed in ~w'-[Where] ].

                                        % delayed output
message(plunit(test_output(_, Output))) -->
    [ '~s'-[Output] ].
					% Interrupts (SWI)
:- if(swi).
message(interrupt(begin)) -->
    { thread_self(Me),
      running(Unit, Test, Line, Progress, Me),
      !,
      unit_file(Unit, File),
      restore_output_state
    },
    [ 'Interrupted test '-[] ],
    running(running(Unit:Test, File:Line, Progress, Me)),
    [nl],
    '$messages':prolog_message(interrupt(begin)).
message(interrupt(begin)) -->
    '$messages':prolog_message(interrupt(begin)).
:- endif.

message(concurrent) -->
    [ 'concurrent(true) at the level of units is currently ignored.', nl,
      'See set_test_options/1 with jobs(Count) for concurrent testing.'
    ].

test_name(Name, forall(Bindings, _Nth-I)) -->
    !,
    test_name(Name, -),
    [ ' (~d-th forall bindings = '-[I],
      ansi(code, '~p', [Bindings]), ')'-[]
    ].
test_name(Name, _) -->
    !,
    [ 'test ', ansi(code, '~q', [Name]) ].

running(running(Unit:Test, File:Line, _Progress, Thread)) -->
    thread(Thread),
    [ '~q:~q at '-[Unit, Test], url(File:Line) ].
running([H|T]) -->
    ['\t'], running(H),
    (   {T == []}
    ->  []
    ;   [nl], running(T)
    ).

thread(main) --> !.
thread(Other) -->
    [' [~w] '-[Other] ].

:- if(swi).
write_term(T, OPS) -->
    ['~W'-[T,OPS] ].
:- else.
write_term(T, _OPS) -->
    ['~q'-[T]].
:- endif.

expected_got_ops_(Ex, E, OPS, Goals) -->
    ['    Expected: '-[]], write_term(Ex, OPS), [nl],
    ['    Got:      '-[]], write_term(E,  OPS), [],
    ( { Goals = [] } -> []
    ; [nl, '       with: '-[]], write_term(Goals, OPS), []
    ).


failure(List) -->
    { is_list(List) },
    !,
    [ nl ],
    failures(List).
failure(Var) -->
    { var(Var) },
    !,
    [ 'Unknown failure?' ].
failure(succeeded(Time)) -->
    !,
    [ 'must fail but succeeded in ~2f seconds~n'-[Time] ].
failure(wrong_error(Expected, Error)) -->
    !,
    { copy_term(Expected-Error, Ex-E, Goals),
      numbervars(Ex-E-Goals, 0, _),
      write_options(OPS)
    },
    [ 'wrong error'-[], nl ],
    expected_got_ops_(Ex, E, OPS, Goals).
failure(wrong_answer(cmp(Var, Cmp))) -->
    { Cmp =.. [Op,Answer,Expected],
      !,
      copy_term(Expected-Answer, Ex-A, Goals),
      numbervars(Ex-A-Goals, 0, _),
      write_options(OPS)
    },
    [ 'wrong answer for ', ansi(code, '~w', [Var]),
      ' (compared using ~w)'-[Op], nl ],
    expected_got_ops_(Ex, A, OPS, Goals).
failure(wrong_answer(Cmp)) -->
    { Cmp =.. [Op,Answer,Expected],
      !,
      copy_term(Expected-Answer, Ex-A, Goals),
      numbervars(Ex-A-Goals, 0, _),
      write_options(OPS)
    },
    [ 'wrong answer (compared using ~w)'-[Op], nl ],
    expected_got_ops_(Ex, A, OPS, Goals).
failure(wrong_answer(CmpExpected, Bindings)) -->
    { (   CmpExpected = all(Cmp)
      ->  Cmp =.. [_Op1,_,Expected],
	  Got = Bindings,
	  Type = all
      ;   CmpExpected = set(Cmp),
	  Cmp =.. [_Op2,_,Expected0],
	  sort(Expected0, Expected),
	  sort(Bindings, Got),
	  Type = set
      )
    },
    [ 'wrong "~w" answer:'-[Type] ],
    [ nl, '    Expected: ~q'-[Expected] ],
    [ nl, '       Found: ~q'-[Got] ].
:- if(swi).
failure(cmp_error(_Cmp, Error)) -->
    { message_to_string(Error, Message) },
    [ 'Comparison error: ~w'-[Message] ].
failure(throw(Error)) -->
    { Error = error(_,_),
      !,
      message_to_string(Error, Message)
    },
    [ 'received error: ~w'-[Message] ].
:- endif.
failure(message) -->
    !,
    [ 'Generated unexpected warning or error'-[] ].
failure(Why) -->
    [ '~p'-[Why] ].

failures([]) -->
    !.
failures([H|T]) -->
    !,
    failure(H), [nl],
    failures(T).

timeout(Limit) -->
    [ 'Timeout exceeeded (~2f sec)'-[Limit] ].

fixme_message([]) --> [].
fixme_message([fixme(Unit, _Name, Line, Reason, How)|T]) -->
    { unit_file(Unit, File) },
    fixme_message(File:Line, Reason, How),
    (   {T == []}
    ->  []
    ;   [nl],
	fixme_message(T)
    ).

fixme_message(Location, Reason, failed) -->
    [ 'FIXME: ~w: ~w'-[Location, Reason] ].
fixme_message(Location, Reason, passed) -->
    [ 'FIXME: ~w: passed ~w'-[Location, Reason] ].
fixme_message(Location, Reason, nondet) -->
    [ 'FIXME: ~w: passed (nondet) ~w'-[Location, Reason] ].


write_options([ numbervars(true),
		quoted(true),
		portray(true),
		max_depth(100),
		attributes(portray)
	      ]).

%!  test_name_summary(+Term, +MaxLen, -Summary) is det.
%
%   Given the test id, generate  string that summarizes this in MaxLen
%   characters.

test_name_summary(Term, MaxLen, Summary) :-
    summary_string(Term, Text),
    atom_length(Text, Len),
    (   Len =< MaxLen
    ->  Summary = Text
    ;   End is MaxLen//2,
        Pre is MaxLen - End - 2,
        sub_string(Text, 0, Pre, _, PreText),
        sub_string(Text, _, End, 0, PostText),
        format(string(Summary), '~w..~w', [PreText,PostText])
    ).

summary_string(Unit:Test, String) =>
    summary_string(Test, String1),
    atomics_to_string([Unit, String1], :, String).
summary_string(@(Name,Vars), String) =>
    format(string(String), '~W (using ~W)',
           [ Name, [numbervars(true), quoted(false)],
             Vars, [numbervars(true), portray(true), quoted(true)]
           ]).
summary_string(Name, String) =>
    term_string(Name, String, [numbervars(true), quoted(false)]).

%!  progress_string(+Progress, -S) is det.
%
%   True when S is a string representation for the test progress.

progress_string(forall(_Vars, N-I)/Total, S) =>
    format(string(S), '~w-~w/~w', [N,I,Total]).
progress_string(Progress, S) =>
    term_string(Progress, S).

%!  progress_tag(+Status, -Tag, -Keep, -Style) is det.
%
%   Given a progress status, determine the status tag, whether we must
%   preserve the  line and the Style  we must use to  print the status
%   line.

progress_tag(passed,        Tag, Keep, Style) =>
    Tag = passed, Keep = false, Style = comment.
progress_tag(fixme(passed), Tag, Keep, Style) =>
    Tag = passed, Keep = false, Style = comment.
progress_tag(fixme(_),      Tag, Keep, Style) =>
    Tag = fixme, Keep = true, Style = warning.
progress_tag(nondet,        Tag, Keep, Style) =>
    Tag = '**NONDET', Keep = true, Style = warning.
progress_tag(timeout(_Limit), Tag, Keep, Style) =>
    Tag = '**TIMEOUT', Keep = true, Style = warning.
progress_tag(assertion,     Tag, Keep, Style) =>
    Tag = '**FAILED', Keep = true, Style = error.
progress_tag(failed,        Tag, Keep, Style) =>
    Tag = '**FAILED', Keep = true, Style = error.
progress_tag(forall(_,0),   Tag, Keep, Style) =>
    Tag = passed, Keep = false, Style = comment.
progress_tag(forall(_,_),   Tag, Keep, Style) =>
    Tag = '**FAILED', Keep = true, Style = error.


		 /*******************************
		 *           OUTPUT		*
		 *******************************/

save_output_state :-
    stream_property(Output, alias(user_output)),
    stream_property(Error, alias(user_error)),
    asserta(output_streams(Output, Error)).

restore_output_state :-
    output_streams(Output, Error),
    !,
    set_stream(Output, alias(user_output)),
    set_stream(Error, alias(user_error)).
restore_output_state.



		 /*******************************
		 *      CONCURRENT STATUS       *
		 *******************************/

/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
This part deals with interactive feedback   when we are running multiple
threads. The terminal window cannot work on   top  of the Prolog message
infrastructure and (thus) we have to use more low-level means.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */

:- dynamic
       jobs/1,			% Count
       job_window/1,		% Count
       job_status_line/3.	% Job, Format, Args

job_feedback(_, jobs(Jobs)) :-
    retractall(jobs(_)),
    Jobs > 1,
    asserta(jobs(Jobs)),
    tty_feedback,
    !,
    retractall(job_window(_)),
    asserta(job_window(Jobs)),
    retractall(job_status_line(_,_,_)),
    jobs_redraw.
job_feedback(_, jobs(Jobs)) :-
    !,
    retractall(job_window(_)),
    info(plunit(jobs(Jobs))).
job_feedback(_, Msg) :-
    job_window(_),
    !,
    with_mutex(plunit_feedback, job_feedback(Msg)).
job_feedback(Level, Msg) :-
    print_message(Level, plunit(Msg)).

job_feedback(begin(Unit:Test, _Location, Progress)) =>
    tty_columns(SummaryWidth, _Margin),
    test_name_summary(Unit:Test, SummaryWidth, NameS),
    progress_string(Progress, ProgressS),
    tty_clear_to_eol(CE),
    job_format(comment, '\r[~w] ~w ..~w',
	       [ProgressS, NameS, CE]),
    flush_output.
job_feedback(end(_UnitTest, _Location, _Progress)) =>
    true.
job_feedback(progress(_UnitTest, Status, _Progress, Time)) =>
    (   hide_progress(Status)
    ->  true
    ;   tty_columns(_SummaryWidth, Margin),
	progress_tag(Status, Tag, _Keep, Style),
	job_finish(Style, '~`.t ~w (~3f sec)~*|',
		   [Tag, Time.wall, Margin])
    ).
job_feedback(failed(UnitTest, Progress, Line, Error, Time, Output)) =>
    tty_columns(_SummaryWidth, Margin),
    progress_tag(failed, Tag, _Keep, Style),
    job_finish(Style, '~`.t ~w (~3f sec)~*|',
	       [Tag, Time.wall, Margin]),
    print_test_output(Error, Output),
    (   (   Error = timeout(_)	% Status line suffices
	;   Error == assertion	% We will get an failed test later
	)
    ->  true
    ;   print_message(Style, plunit(failed(UnitTest, Progress, Line,
					   Error, Time, "")))
    ),
    jobs_redraw.
job_feedback(begin(_Unit)) => true.
job_feedback(end(_Unit, _Summary)) => true.

hide_progress(assertion).
hide_progress(forall(_,_)).
hide_progress(failed).
hide_progress(timeout(_)).

print_test_output(Error, _Msgs-Output) =>
    print_test_output(Error, Output).
print_test_output(_, "") => true.
print_test_output(assertion, Output) =>
    print_message(debug, plunit(test_output(error, Output))).
print_test_output(message, Output) =>
    print_message(debug, plunit(test_output(error, Output))).
print_test_output(_, Output) =>
    print_message(debug, plunit(test_output(informational, Output))).

%!  jobs_redraw is det.
%
%   Redraw the job window.

jobs_redraw :-
    job_window(N),
    !,
    tty_columns(_, Width),
    tty_header_line(Width),
    forall(between(1,N,Line), job_redraw_worker(Line)),
    tty_header_line(Width).
jobs_redraw.

job_redraw_worker(Line) :-
    (   job_status_line(Line, Fmt, Args)
    ->  ansi_format(comment, Fmt, Args)
    ;   true
    ),
    nl.

%!  job_format(+Style, +Fmt, +Args) is det.
%!  job_format(+Job, +Style, +Fmt, +Args, +Save) is det.
%
%   Point should be  below the status window.  Format  Fmt+Args in the
%   line Job using Style and return to the position below the window.

job_format(Style, Fmt, Args) :-
    job_self(Job),
    job_format(Job, Style, Fmt, Args, true).

%!  job_finish(+Style, +Fmt, +Args) is det.
%!  job_finish(+Job, +Style, +Fmt, +Args) is det.
%
%   Complete  the status  line  for Job.   This  redraws the  original
%   status line when we are using a job window.

job_finish(Style, Fmt, Args) :-
    job_self(Job),
    job_finish(Job, Style, Fmt, Args).

:- det(job_finish/4).
job_finish(Job, Style, Fmt, Args) :-
    retract(job_status_line(Job, Fmt0, Args0)),
    !,
    string_concat(Fmt0, Fmt, Fmt1),
    append(Args0, Args, Args1),
    job_format(Job, Style, Fmt1, Args1, false).

:- det(job_format/5).
job_format(Job, Style, Fmt, Args, Save) :-
    job_window(Jobs),
    Up is Jobs+2-Job,
    flush_output(user_output),
    tty_up_and_clear(Up),
    ansi_format(Style, Fmt, Args),
    (   Save == true
    ->  retractall(job_status_line(Job, _, _)),
	asserta(job_status_line(Job, Fmt, Args))
    ;   true
    ),
    tty_down_and_home(Up),
    flush_output(user_output).

:- det(job_self/1).
job_self(Job) :-
    job_window(N),
    N > 1,
    thread_self(Me),
    split_string(Me, '_', '', [_,_,S]),
    number_string(Job, S).

%!  feedback is semidet.
%
%   provide feedback using the `tty`  format, which reuses the current
%   output line if the test is successful.

tty_feedback :-
    has_tty,
    current_test_flag(format, tty).

has_tty :-
    stream_property(user_output, tty(true)).

tty_columns(SummaryWidth, Margin) :-
    tty_width(W),
    Margin is W-8,
    SummaryWidth is max(20,Margin-34).

tty_width(W) :-
    current_predicate(tty_size/2),
    catch(tty_size(_Rows, Cols), error(_,_), fail),
    Cols > 25,
    !,
    W = Cols.
tty_width(80).

tty_header_line(Width) :-
    ansi_format(comment, '~N~`\u2015t~*|~n', [Width]).

:- if(current_predicate(tty_get_capability/3)).
tty_clear_to_eol(S) :-
    tty_get_capability(ce, string, S),
    !.
:- endif.
tty_clear_to_eol('\e[K').

tty_up_and_clear(Lines) :-
    format(user_output, '\e[~dA\r\e[K', [Lines]).

tty_down_and_home(Lines) :-
    format(user_output, '\e[~dB\r', [Lines]).

:- if(swi).

:- multifile
    prolog:message/3,
    user:message_hook/3.

prolog:message(Term) -->
    message(Term).

%       user:message_hook(+Term, +Kind, +Lines)

user:message_hook(make(done(Files)), _, _) :-
    make_run_tests(Files),
    fail.                           % give other hooks a chance

:- endif.

:- if(sicstus).

user:generate_message_hook(Message) -->
    message(Message),
    [nl].                           % SICStus requires nl at the end

%!  user:message_hook(+Severity, +Message, +Lines) is semidet.
%
%   Redefine printing some messages. It appears   SICStus has no way
%   to get multiple messages at the same   line, so we roll our own.
%   As there is a lot pre-wired and   checked in the SICStus message
%   handling we cannot reuse the lines. Unless I miss something ...

user:message_hook(informational, plunit(begin(Unit)), _Lines) :-
    format(user_error, '% PL-Unit: ~w ', [Unit]),
    flush_output(user_error).
user:message_hook(informational, plunit(end(_Unit)), _Lines) :-
    format(user, ' done~n', []).

:- endif.
