/*  Part of SWI-Prolog

    Author:        Jan Wielemaker
    E-mail:        J.Wielemaker@cs.vu.nl
    WWW:           http://www.swi-prolog.org
    Copyright (C): 2006-2014, University of Amsterdam
			      VU University Amsterdam

    This program is free software; you can redistribute it and/or
    modify it under the terms of the GNU General Public License
    as published by the Free Software Foundation; either version 2
    of the License, or (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public
    License along with this library; if not, write to the Free Software
    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA

    As a special exception, if you link this library with other files,
    compiled with a Free Software compiler, to produce an executable, this
    library does not by itself cause the resulting executable to be covered
    by the GNU General Public License. This exception does not however
    invalidate any other reasons why the executable file might be covered by
    the GNU General Public License.

    Alternatively, this program may be distributed under the Perl
    Artistic License, version 2.0.
*/

:- 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,		% Run named test-set
	    load_test_files/1,		% +Options
	    running_tests/0,		% Prints currently running test
	    test_report/1		% +What
	  ]).

/** <module> Unit Testing

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

@author		Jan Wielemaker
@license	GPL+SWI-exception or Artistic 2.0
*/

:- use_module(library(apply)).
:- use_module(library(ordsets), [ord_intersection/3]).
:- meta_predicate valid_options(+, 1).


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

:- discontiguous
	user:term_expansion/2.

:- dynamic
	include_code/1.

including :-
	include_code(X), !,
	X == true.
including.

if_expansion((:- if(G)), []) :-
	(   including
	->  (   catch(G, E, (print_message(error, E), fail))
	    ->  asserta(include_code(true))
	    ;   asserta(include_code(false))
	    )
	;   asserta(include_code(else_false))
	).
if_expansion((:- else), []) :-
	(   retract(include_code(X))
	->  (   X == true
	    ->  X2 = false
	    ;   X == false
	    ->	X2 = true
	    ;	X2 = X
	    ),
	    asserta(include_code(X2))
	;   throw_error(context_error(no_if),_)
	).
if_expansion((:- endif), []) :-
	retract(include_code(_)), !.

if_expansion(_, []) :-
	\+ including.

user:term_expansion(In, Out) :-
	prolog_load_context(module, plunit),
	if_expansion(In, Out).

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


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

:- set_prolog_flag(generate_debug_info, false).
:- use_module(library(option)).
:- use_module(library(pairs)).

current_test_flag(Name, Value) :-
	current_prolog_flag(Name, Value).

set_test_flag(Name, Value) :-
	create_prolog_flag(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))).

:- if(current_prolog_flag(dialect, yap)).

'$set_predicate_attribute'(_, _, _).

:- endif.
:- endif.

:- if(sicstus).
throw_error(Error_term,Impldef) :-
	throw(error(Error_term,i(Impldef))). % SICStus 3 work around

:- use_module(swi).			% SWI-Compatibility
:- use_module(library(terms)).
:- op(700, xfx, =@=).

'$set_source_module'(_, _).

%%	current_test_flag(?Name, ?Value) is nondet.
%
%	Query  flags  that  control  the    testing   process.  Emulates
%	SWI-Prologs flags.

:- dynamic test_flag/2.	% Name, Val

current_test_flag(optimise, Val) :-
	current_prolog_flag(compiling, Compiling),
	(   Compiling == debugcode ; true % TBD: Proper test
	->  Val = false
	;   Val = true
	).
current_test_flag(Name, Val) :-
	test_flag(Name, Val).


%%	set_test_flag(+Name, +Value) is det.

set_test_flag(Name, Val) :-
	var(Name), !,
	throw_error(instantiation_error, set_test_flag(Name,Val)).
set_test_flag( Name, Val ) :-
	retractall(test_flag(Name,_)),
	asserta(test_flag(Name, Val)).

:- op(1150, fx, thread_local).

user:term_expansion((:- thread_local(PI)), (:- dynamic(PI))) :-
	prolog_load_context(module, plunit).

:- endif.

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

:- use_module(library(lists)).

:- initialization
   (   current_test_flag(test_options, _)
   ->  true
   ;   set_test_flag(test_options,
		     [ run(make),	% run tests on make/0
		       sto(false)
		     ])
   ).

%%	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).
%
%		* silent(+Bool)
%		If =true= (default =false=), report successful tests
%		using message level =silent=, only printing errors and
%		warnings.
%
%		* sto(+Bool)
%		How to test whether code is subject to occurs check
%		(STO).  If =false= (default), STO is not considered.
%		If =true= and supported by the hosting Prolog, code
%		is run in all supported unification mode and reported
%		if the results are inconsistent.
%
%		* 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.

set_test_options(Options) :-
	valid_options(Options, global_test_option),
	set_test_flag(test_options, Options).

global_test_option(load(Load)) :-
	must_be(oneof([never,always,normal]), Load).
global_test_option(run(When)) :-
	must_be(oneof([manual,make,make(all)]), When).
global_test_option(silent(Bool)) :-
	must_be(boolean, Bool).
global_test_option(sto(Bool)) :-
	must_be(boolean, Bool).
global_test_option(cleanup(Bool)) :-
	must_be(boolean, Bool).


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

loading_tests :-
	current_test_flag(test_options, Options),
	option(load(Load), Options, normal),
	(   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) :-
	valid_options(Options, test_set_option),
	make_unit_module(Unit, Name),
	source_location(File, Line),
	begin_tests(Unit, Name, File:Line, Options).

:- 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, 0),
	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),
	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, Options1, Options2),
	valid_options(Options2, test_option),
	valid_test_mode(Options2, Options).

expand_option(Var, _) :-
	var(Var), !,
	throw_error(instantiation_error,_).
expand_option(A == B, true(A==B)) :- !.
expand_option(A = B, true(A=B)) :- !.
expand_option(A =@= B, true(A=@=B)) :- !.
expand_option(A =:= B, true(A=:=B)) :- !.
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).

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)), _).

:- if(swi).
:- multifile
	system:term_expansion/2.
:- endif.

system:term_expansion(Term, Expanded) :-
	(   loading_unit(_, _, File, _)
	->  source_location(File, _),
	    expand(Term, Expanded)
	).


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

:- if(swi).
:- use_module(library(error)).
:- else.
must_be(list, X) :- !,
	(   is_list(X)
	->  true
	;   is_not(list, X)
	).
must_be(Type, X) :-
	(   call(Type, X)
	->  true
	;   is_not(Type, X)
	).

is_not(Type, X) :-
	(   ground(X)
	->  throw_error(type_error(Type, X), _)
	;   throw_error(instantiation_error, _)
	).
:- endif.

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

valid_options(Options, Pred) :-
	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), _)
	).


%%	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(+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(sto(V)) :-
	nonvar(V), member(V, [finite_trees, rational_trees]).


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

:- thread_local
	passed/5,			% Unit, Test, Line, Det, Time
	failed/4,			% Unit, Test, Line, Reason
	failed_assertion/7,		% Unit, Test, Line, ALoc, STO, Reason, Goal
	blocked/4,			% Unit, Test, Line, Reason
	sto/4,				% Unit, Test, Line, Results
	fixme/5.			% Unit, Test, Line, Reason, Status

:- dynamic
	running/5.			% Unit, Test, Line, STO, Thread

%%	run_tests is semidet.
%%	run_tests(+TestSet) 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.
%	This  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.

run_tests :-
	cleanup,
	setup_call_cleanup(
	    setup_trap_assertions(Ref),
	    run_current_units,
	    report_and_cleanup(Ref)).

run_current_units :-
	forall(current_test_set(Set),
	       run_unit(Set)),
	check_for_test_errors.

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

run_tests(Set) :-
	cleanup,
	setup_call_cleanup(
	    setup_trap_assertions(Ref),
	    run_unit_and_check_errors(Set),
	    report_and_cleanup(Ref)).

run_unit_and_check_errors(Set) :-
	run_unit(Set),
	check_for_test_errors.

run_unit([]) :- !.
run_unit([H|T]) :- !,
	run_unit(H),
	run_unit(T).
run_unit(Spec) :-
	unit_from_spec(Spec, Unit, Tests, Module, UnitOptions),
	(   option(blocked(Reason), UnitOptions)
	->  info(plunit(blocked(unit(Unit, Reason))))
	;   setup(Module, unit(Unit), UnitOptions)
	->  info(plunit(begin(Spec))),
	    forall((Module:'unit test'(Name, Line, Options, Body),
		    matching_test(Name, Tests)),
		   run_test(Unit, Name, Line, Options, Body)),
	    info(plunit(end(Spec))),
	    (	message_level(silent)
	    ->	true
	    ;	format(user_error, '~N', [])
	    ),
	    cleanup(Module, UnitOptions)
	;   true
	).

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


matching_test(X, X) :- !.
matching_test(Name, Set) :-
	is_list(Set),
	memberchk(Name, Set).

cleanup :-
	thread_self(Me),
	retractall(passed(_, _, _, _, _)),
	retractall(failed(_, _, _, _)),
	retractall(failed_assertion(_, _, _, _, _, _, _)),
	retractall(blocked(_, _, _, _)),
	retractall(sto(_, _, _, _)),
	retractall(fixme(_, _, _, _, _)),
	retractall(running(_,_,_,_,Me)).

cleanup_after_test :-
	current_test_flag(test_options, Options),
	option(cleanup(Cleanup), Options, false),
	(   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(test_options, Options),
	option(run(When), Options, manual),
	(   When == make
	->  run_tests_in_files(Files)
	;   When == make(all)
	->  run_tests
	;   true
	).

:- if(swi).

unification_capability(sto_error_incomplete).
% can detect some (almost all) STO runs
unification_capability(rational_trees).
unification_capability(finite_trees).

set_unification_capability(Cap) :-
	cap_to_flag(Cap, Flag),
	set_prolog_flag(occurs_check, Flag).

current_unification_capability(Cap) :-
	current_prolog_flag(occurs_check, Flag),
	cap_to_flag(Cap, Flag), !.

cap_to_flag(sto_error_incomplete, error).
cap_to_flag(rational_trees, false).
cap_to_flag(finite_trees, true).

:- else.
:- if(sicstus).

unification_capability(rational_trees).
set_unification_capability(rational_trees).
current_unification_capability(rational_trees).

:- else.

unification_capability(_) :-
	fail.

:- endif.
:- endif.

		 /*******************************
		 *	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, STO, Me),
	(   catch(get_prolog_backtrace(10, Stack), _, fail),
	    assertion_location(Stack, AssertLoc)
	->  true
	;   AssertLoc = unknown
	),
	current_test_flag(test_options, Options),
	report_failed_assertion(Unit, Test, Line, AssertLoc,
				STO, Reason, Goal, Options),
	assert_cyclic(failed_assertion(Unit, Test, Line, AssertLoc,
				       STO, 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(Unit, Test, Line, AssertLoc,
			STO, Reason, Goal, _Options) :-
	print_message(
	    error,
	    plunit(failed_assertion(Unit, Test, Line, AssertLoc,
				    STO, Reason, Goal))).

:- else.

setup_trap_assertions(_).
cleanup_trap_assertions(_).

:- endif.





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

%%	run_test(+Unit, +Name, +Line, +Options, +Body) is det.
%
%	Run a single test.

run_test(Unit, Name, Line, Options, Body) :-
	option(forall(Generator), Options), !,
	unit_module(Unit, Module),
	term_variables(Generator, Vars),
	forall(Module:Generator,
	       run_test_once(Unit, @(Name,Vars), Line, Options, Body)).
run_test(Unit, Name, Line, Options, Body) :-
	run_test_once(Unit, Name, Line, Options, Body).

run_test_once(Unit, Name, Line, Options, Body) :-
	current_test_flag(test_options, GlobalOptions),
	option(sto(false), GlobalOptions, false), !,
	current_unification_capability(Type),
	begin_test(Unit, Name, Line, Type),
	run_test_6(Unit, Name, Line, Options, Body, Result),
	end_test(Unit, Name, Line, Type),
	report_result(Result, Options).
run_test_once(Unit, Name, Line, Options, Body) :-
	current_unit(Unit, _Module, _Supers, UnitOptions),
	option(sto(Type), UnitOptions),
	\+ option(sto(_), Options), !,
	current_unification_capability(Cap0),
	call_cleanup(run_test_cap(Unit, Name, Line, [sto(Type)|Options], Body),
		     set_unification_capability(Cap0)).
run_test_once(Unit, Name, Line, Options, Body) :-
	current_unification_capability(Cap0),
	call_cleanup(run_test_cap(Unit, Name, Line, Options, Body),
		     set_unification_capability(Cap0)).

run_test_cap(Unit, Name, Line, Options, Body) :-
	(   option(sto(Type), Options)
	->  unification_capability(Type),
	    set_unification_capability(Type),
	    begin_test(Unit, Name, Line, Type),
	    run_test_6(Unit, Name, Line, Options, Body, Result),
	    end_test(Unit, Name, Line, Type),
	    report_result(Result, Options)
	;   findall(Key-(Type+Result),
		    test_caps(Type, Unit, Name, Line, Options, Body, Result, Key),
		    Pairs),
	    group_pairs_by_key(Pairs, Keyed),
	    (	Keyed == []
	    ->	true
	    ;	Keyed = [_-Results]
	    ->	Results = [_Type+Result|_],
		report_result(Result, Options)		% consistent results
	    ;	pairs_values(Pairs, ResultByType),
		report_result(sto(Unit, Name, Line, ResultByType), Options)
	    )
	).

%%	test_caps(-Type, +Unit, +Name, +Line, +Options, +Body, -Result, -Key) is nondet.

test_caps(Type, Unit, Name, Line, Options, Body, Result, Key) :-
	unification_capability(Type),
	set_unification_capability(Type),
	begin_test(Unit, Name, Line, Type),
	run_test_6(Unit, Name, Line, Options, Body, Result),
	end_test(Unit, Name, Line, Type),
	result_to_key(Result, Key),
	Key \== setup_failed.

result_to_key(blocked(_, _, _, _), blocked).
result_to_key(failure(_, _, _, How0), failure(How1)) :-
	( How0 = succeeded(_T) -> How1 = succeeded ; How0 = How1 ).
result_to_key(success(_, _, _, Determinism, _), success(Determinism)).
result_to_key(setup_failed(_,_,_), setup_failed).

report_result(blocked(Unit, Name, Line, Reason), _) :- !,
	assert(blocked(Unit, Name, Line, Reason)).
report_result(failure(Unit, Name, Line, How), Options) :- !,
	failure(Unit, Name, Line, How, Options).
report_result(success(Unit, Name, Line, Determinism, Time), Options) :- !,
	success(Unit, Name, Line, Determinism, Time, Options).
report_result(setup_failed(_Unit, _Name, _Line), _Options).
report_result(sto(Unit, Name, Line, ResultByType), Options) :-
	assert(sto(Unit, Name, Line, ResultByType)),
	print_message(error, plunit(sto(Unit, Name, Line))),
	report_sto_results(ResultByType, Options).

report_sto_results([], _).
report_sto_results([Type+Result|T], Options) :-
	print_message(error, plunit(sto(Type, Result))),
	report_sto_results(T, Options).


%%	run_test_6(+Unit, +Name, +Line, +Options, :Body, -Result) is det.
%
%	Result is one of:
%
%		* blocked(Unit, Name, Line, Reason)
%		* failure(Unit, Name, Line, How)
%		* success(Unit, Name, Line, Determinism, Time)
%		* setup_failed(Unit, Name, Line)

run_test_6(Unit, Name, Line, Options, _Body,
	   blocked(Unit, Name, Line, Reason)) :-
	option(blocked(Reason), Options), !.
run_test_6(Unit, Name, Line, Options, Body, Result) :-
	option(all(Answer), Options), !,		% all(Bindings)
	nondet_test(all(Answer), Unit, Name, Line, Options, Body, Result).
run_test_6(Unit, Name, Line, Options, Body, Result) :-
	option(set(Answer), Options), !,		% set(Bindings)
	nondet_test(set(Answer), Unit, Name, Line, Options, Body, Result).
run_test_6(Unit, Name, Line, Options, Body, Result) :-
	option(fail, Options), !,			% fail
	unit_module(Unit, Module),
	(   setup(Module, test(Unit,Name,Line), Options)
	->  statistics(runtime, [T0,_]),
	    (   catch(Module:Body, E, true)
	    ->  (   var(E)
		->  statistics(runtime, [T1,_]),
		    Time is (T1 - T0)/1000.0,
		    Result = failure(Unit, Name, Line, succeeded(Time)),
		    cleanup(Module, Options)
		;   Result = failure(Unit, Name, Line, E),
		    cleanup(Module, Options)
		)
	    ;   statistics(runtime, [T1,_]),
		Time is (T1 - T0)/1000.0,
		Result = success(Unit, Name, Line, true, Time),
		cleanup(Module, Options)
	    )
	;   Result = setup_failed(Unit, Name, Line)
	).
run_test_6(Unit, Name, Line, Options, Body, Result) :-
	option(true(Cmp), Options), !,
	unit_module(Unit, Module),
	(   setup(Module, test(Unit,Name,Line), Options) % true(Binding)
	->  statistics(runtime, [T0,_]),
	    (   catch(call_det(Module:Body, Det), E, true)
	    ->  (   var(E)
		->  statistics(runtime, [T1,_]),
		    Time is (T1 - T0)/1000.0,
		    (   catch(Module:Cmp, E, true)
		    ->  (   var(E)
			->  Result = success(Unit, Name, Line, Det, Time)
			;   Result = failure(Unit, Name, Line, cmp_error(Cmp, E))
			)
		    ;   Result = failure(Unit, Name, Line, wrong_answer(Cmp))
		    ),
		    cleanup(Module, Options)
		;   Result = failure(Unit, Name, Line, E),
		    cleanup(Module, Options)
		)
	    ;   Result = failure(Unit, Name, Line, failed),
		cleanup(Module, Options)
	    )
	;   Result = setup_failed(Unit, Name, Line)
	).
run_test_6(Unit, Name, Line, Options, Body, Result) :-
	option(throws(Expect), Options), !,
	unit_module(Unit, Module),
	(   setup(Module, test(Unit,Name,Line), Options)
	->  statistics(runtime, [T0,_]),
	    (   catch(Module:Body, E, true)
	    ->  (   var(E)
		->  Result = failure(Unit, Name, Line, no_exception),
		    cleanup(Module, Options)
		;   statistics(runtime, [T1,_]),
		    Time is (T1 - T0)/1000.0,
		    (   match_error(Expect, E)
		    ->  Result = success(Unit, Name, Line, true, Time)
		    ;   Result = failure(Unit, Name, Line, wrong_error(Expect, E))
		    ),
		    cleanup(Module, Options)
		)
	    ;   Result = failure(Unit, Name, Line, failed),
		cleanup(Module, Options)
	    )
	;   Result = setup_failed(Unit, Name, Line)
	).


%%	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),
	statistics(runtime, [T0,_]),
	(   setup(Module, test(Unit,Name,Line), Options)
	->  (   catch(findall(Vars, Module:Body, Bindings), E, true)
	    ->  (   var(E)
		->  statistics(runtime, [T1,_]),
		    Time is (T1 - T0)/1000.0,
		    (   nondet_compare(Expected, Bindings, Unit, Name, Line)
		    ->  Result = success(Unit, Name, Line, true, Time)
		    ;   Result = failure(Unit, Name, Line, wrong_answer(Expected, Bindings))
		    ),
		    cleanup(Module, Options)
		;   Result = failure(Unit, Name, Line, E),
		    cleanup(Module, Options)
		)
	    )
	;   Result = setup_failed(Unit, Name, Line)
	).


%%	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(condition(Condition), Options),
	option(setup(Setup), Options), !,
	setup(Module, Context, [condition(Condition)]),
	setup(Module, Context, [setup(Setup)]).
setup(Module, Context, Options) :-
	option(setup(Setup), Options), !,
	(   catch(call_ex(Module, Setup), E, true)
	->  (   var(E)
	    ->	true
	    ;	print_message(error, plunit(error(setup, Context, E))),
		fail
	    )
	;   print_message(error, error(goal_failed(Setup), _)),
	    fail
	).
setup(Module, Context, Options) :-
	option(condition(Setup), Options), !,
	(   catch(call_ex(Module, Setup), E, true)
	->  (   var(E)
	    ->	true
	    ;	print_message(error, plunit(error(condition, Context, E))),
		fail
	    )
	;   fail
	).
setup(_,_,_).

%%	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, Line, Det, _Time, Options) :-
	memberchk(fixme(Reason), Options), !,
	(   (   Det == true
	    ;	memberchk(nondet, Options)
	    )
	->  put_char(user_error, +),
	    Ok = passed
	;   put_char(user_error, !),
	    Ok = nondet
	),
	flush_output(user_error),
	assert(fixme(Unit, Name, Line, Reason, Ok)).
success(Unit, Name, Line, _, _, Options) :-
	failed_assertion(Unit, Name, Line, _,_,_,_), !,
	failure(Unit, Name, Line, assertion, Options).
success(Unit, Name, Line, Det, Time, Options) :-
	assert(passed(Unit, Name, Line, Det, Time)),
	(   (   Det == true
	    ;	memberchk(nondet, Options)
	    )
	->  put_char(user_error, .)
	;   unit_file(Unit, File),
	    print_message(warning, plunit(nondet(File, Line, Name)))
	),
	flush_output(user_error).

failure(Unit, Name, Line, _, Options) :-
	memberchk(fixme(Reason), Options), !,
	put_char(user_error, -),
	flush_output(user_error),
	assert(fixme(Unit, Name, Line, Reason, failed)).
failure(Unit, Name, Line, E, Options) :-
	report_failure(Unit, Name, Line, E, Options),
	assert_cyclic(failed(Unit, Name, Line, E)).

%%	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.


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

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

begin_test(Unit, Test, Line, STO) :-
	thread_self(Me),
	assert(running(Unit, Test, Line, STO, Me)),
	unit_file(Unit, File),
	print_message(silent, plunit(begin(Unit:Test, File:Line, STO))).

end_test(Unit, Test, Line, STO) :-
	thread_self(Me),
	retractall(running(_,_,_,_,Me)),
	unit_file(Unit, File),
	print_message(silent, plunit(end(Unit:Test, File:Line, STO))).

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

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

running_tests(Running) :-
	findall(running(Unit:Test, File:Line, STO, Thread),
		(   running(Unit, Test, Line, STO, Thread),
		    unit_file(Unit, File)
		), Running).


%%	check_for_test_errors is semidet.
%
%	True if there are no errors, otherwise false.

check_for_test_errors :-
	number_of_clauses(failed/4, Failed),
	number_of_clauses(failed_assertion/7, FailedAssertion),
	number_of_clauses(sto/4, STO),
	Failed+FailedAssertion+STO =:= 0.     % fail on errors


%%	report is det.
%
%	Print a summary of the tests that ran.

report :-
	number_of_clauses(passed/5, Passed),
	number_of_clauses(failed/4, Failed),
	number_of_clauses(failed_assertion/7, FailedAssertion),
	number_of_clauses(blocked/4, Blocked),
	number_of_clauses(sto/4, STO),
	(   Passed+Failed+FailedAssertion+Blocked+STO =:= 0
	->  info(plunit(no_tests))
	;   Failed+FailedAssertion+Blocked+STO =:= 0
	->  report_fixme,
	    info(plunit(all_passed(Passed)))
	;   report_blocked,
	    report_fixme,
	    report_failed_assertions,
	    report_failed,
	    report_sto,
	    info(plunit(passed(Passed)))
	).

number_of_clauses(F/A,N) :-
	(   current_predicate(F/A)
	->  functor(G,F,A),
	    findall(t, G, Ts),
	    length(Ts, N)
	;   N = 0
	).

report_blocked :-
	number_of_clauses(blocked/4,N),
	N > 0, !,
	info(plunit(blocked(N))),
	(   blocked(Unit, Name, Line, Reason),
	    unit_file(Unit, File),
	    print_message(informational,
			  plunit(blocked(File:Line, Name, Reason))),
	    fail ; true
	).
report_blocked.

report_failed :-
	number_of_clauses(failed/4, N),
	info(plunit(failed(N))).

report_failed_assertions :-
	number_of_clauses(failed_assertion/7, N),
	info(plunit(failed_assertions(N))).

report_sto :-
	number_of_clauses(sto/4, N),
	info(plunit(sto(N))).

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(_, _, _, assertion, _) :- !,
	put_char(user_error, 'A').
report_failure(Unit, Name, Line, Error, _Options) :-
	print_message(error, plunit(failed(Unit, Name, Line, Error))).


%%	test_report(What) is det.
%
%	Produce reports on test results after the run.

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		*
		 *******************************/

%%	current_test_set(?Unit) is nondet.
%
%	True if Unit is a currently loaded test-set.

current_test_set(Unit) :-
	current_unit(Unit, _Module, _Context, _Options).

%%	unit_file(+Unit, -File) is det.
%%	unit_file(-Unit, +File) is nondet.

unit_file(Unit, File) :-
	current_unit(Unit, Module, _Context, _Options),
	current_module(Module, File).
unit_file(Unit, PlFile) :-
	nonvar(PlFile),
	test_file_for(TestFile, PlFile),
	current_module(Module, TestFile),
	current_unit(Unit, Module, _Context, _Options).


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

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

load_test_files(_Options) :-
	(   source_file(File),
	    file_name_extension(Base, Old, File),
	    Old \== plt,
	    file_name_extension(Base, plt, TestFile),
	    exists_file(TestFile),
	    (	test_file_for(TestFile, File)
	    ->	true
	    ;	load_files(TestFile,
			   [ if(changed),
			     imports([])
			   ]),
		asserta(test_file_for(TestFile, File))
	    ),
	    fail ; true
	).



		 /*******************************
		 *	     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).

message_level(Level) :-
	current_test_flag(test_options, Options),
	option(silent(Silent), Options, false),
	(   Silent == false
	->  Level = informational
	;   Level = silent
	).

locationprefix(File:Line) --> !,
	[ '~w:~d:\n\t'-[File,Line]].
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.

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] ].

					% Unit start/end
:- if(swi).
message(plunit(begin(Unit))) -->
	[ 'PL-Unit: ~w '-[Unit], flush ].
message(plunit(end(_Unit))) -->
	[ at_same_line, ' done' ].
:- else.
message(plunit(begin(Unit))) -->
	[ 'PL-Unit: ~w '-[Unit]/*, flush-[]*/ ].
message(plunit(end(_Unit))) -->
	[ ' done'-[] ].
:- endif.
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).

					% Blocked tests
message(plunit(blocked(1))) --> !,
	[ 'one test is blocked:'-[] ].
message(plunit(blocked(N))) -->
	[ '~D tests are blocked:'-[N] ].
message(plunit(blocked(Pos, Name, Reason))) -->
	locationprefix(Pos),
	test_name(Name),
	[ ': ~w'-[Reason] ].

					% fail/success
message(plunit(no_tests)) --> !,
	[ 'No tests to run' ].
message(plunit(all_passed(1))) --> !,
	[ 'test passed' ].
message(plunit(all_passed(Count))) --> !,
	[ 'All ~D tests passed'-[Count] ].
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(failed_assertions(0))) --> !,
	[].
message(plunit(failed_assertions(1))) --> !,
	[ '1 assertion failed'-[] ].
message(plunit(failed_assertions(N))) -->
	[ '~D assertions failed'-[N] ].
message(plunit(sto(0))) --> !,
	[].
message(plunit(sto(N))) -->
	[ '~D test results depend on unification mode'-[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(failed(Unit, Name, Line, Failure))) -->
       { unit_file(Unit, File) },
       locationprefix(File:Line),
       test_name(Name),
       [': '-[] ],
       failure(Failure).
:- if(swi).
message(plunit(failed_assertion(Unit, Name, Line, AssertLoc,
				_STO, Reason, Goal))) -->
       { unit_file(Unit, File) },
       locationprefix(File:Line),
       test_name(Name),
       [ ': 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 ~w:~w'-[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).

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

					% STO messages
message(plunit(sto(Unit, Name, Line))) -->
	{ unit_file(Unit, File) },
       locationprefix(File:Line),
       test_name(Name),
       [' is subject to occurs check (STO): '-[] ].
message(plunit(sto(Type, Result))) -->
	sto_type(Type),
	sto_result(Result).

					% Interrupts (SWI)
:- if(swi).
message(interrupt(begin)) -->
	{ thread_self(Me),
	  running(Unit, Test, Line, STO, Me), !,
	  unit_file(Unit, File)
	},
	[ 'Interrupted test '-[] ],
	running(running(Unit:Test, File:Line, STO, Me)),
	[nl],
	'$messages':prolog_message(interrupt(begin)).
message(interrupt(begin)) -->
	'$messages':prolog_message(interrupt(begin)).
:- endif.

test_name(@(Name,Bindings)) --> !,
	[ 'test ~w (forall bindings = ~p)'-[Name, Bindings] ].
test_name(Name) --> !,
	[ 'test ~w'-[Name] ].

sto_type(sto_error_incomplete) -->
	[ 'Finite trees (error checking): ' ].
sto_type(rational_trees) -->
	[ 'Rational trees: ' ].
sto_type(finite_trees) -->
	[ 'Finite trees: ' ].

sto_result(success(_Unit, _Name, _Line, Det, Time)) -->
	det(Det),
	[ ' success in ~2f seconds'-[Time] ].
sto_result(failure(_Unit, _Name, _Line, How)) -->
	failure(How).

det(true) -->
	[ 'deterministic' ].
det(false) -->
	[ 'non-deterministic' ].

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

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

current_sto(sto_error_incomplete) -->
	[ ' (STO: error checking)' ].
current_sto(rational_trees) -->
	[].
current_sto(finite_trees) -->
	[ ' (STO: occurs check enabled)' ].

:- if(swi).
write_term(T, OPS) -->
	['~@'-[write_term(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), [nl],
	( { Goals = [] } -> []
	; ['       with: '-[]], write_term(Goals, OPS), [nl]
	).


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)) -->
	{ 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(Error) -->
	{ Error = error(_,_), !,
	  message_to_string(Error, Message)
	},
	[ 'received error: ~w'-[Message] ].
:- endif.
failure(Why) -->
	[ '~p~n'-[Why] ].

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(10),
		attributes(portray)
	      ]).

:- 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.