/* Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: J.Wielemaker@cs.vu.nl
WWW: http://www.swi-prolog.org
Copyright (C): 2006-2013, 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, []).
:- 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'( In, Out) :-
current_source_module(In, Out).
%% 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 dmwfc.
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) :-
trace,
begin_tests(Unit, []).
begin_tests(Unit, Options) :-
% writeln('*************'+ Unit), trace,
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)).
'$declare_module'( Name, Class, Context, File, Line, _AllowFile ) :-
Name \= Context,
!,
set_module_property( Name, base(Context) ),
set_module_property( Name, class(Class) ),
set_module_property( Name, exports([], File, Line) ).
'$declare_module'( Name, _Class, Name, _File, _Line, _AllowFile ) .
:- 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).
% writeln([ 'unit test'(Name, Line, Options, Module:'unit body'(Id, Vars)),
% ('unit body'(Id, Vars) :- !, Body)
% ]).
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
user:term_expansion/2.
:- endif.
user:term_expansion(Term, Expanded) :-
%writeln(Term),
( 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),
( forall(current_test_set(Set),
run_unit(Set)),
check_for_test_errors
),
( cleanup_trap_assertions(Ref),
report,
cleanup_after_test
)).
run_tests(Set) :-
cleanup,
setup_call_cleanup(
setup_trap_assertions(Ref),
( run_unit(Set),
% writeln(done),
check_for_test_errors
),
( cleanup_trap_assertions(Ref),
report,
cleanup_after_test
)).
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 user:assertion_failed/2.
setup_trap_assertions(Ref) :-
asserta((user: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) %, writeln(F/A)
-> functor(G,F,A),
% writeln( 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
message/3,
user:message_hook/3.
% 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.