From 50e94c909494de135dfe53776915670e8470b510 Mon Sep 17 00:00:00 2001 From: Vitor Santos Costa Date: Sun, 31 Jul 2016 11:35:10 -0500 Subject: [PATCH] support plant --- swi/library/CMakeLists.txt | 7 +- swi/library/debug.pl | 8 +- swi/library/error.pl | 1 + swi/library/plunit.pl | 1730 ++++++++++++++++++++++++++++++++++++ swi/library/unix.pl | 3 + 5 files changed, 1741 insertions(+), 8 deletions(-) create mode 100644 swi/library/error.pl create mode 100644 swi/library/plunit.pl create mode 100644 swi/library/unix.pl diff --git a/swi/library/CMakeLists.txt b/swi/library/CMakeLists.txt index ddae97d9b..dc6194658 100644 --- a/swi/library/CMakeLists.txt +++ b/swi/library/CMakeLists.txt @@ -6,6 +6,7 @@ set (LIBRARY_PL date.pl debug.pl edit.pl + error.pl main.pl menu.pl nb_set.pl @@ -13,6 +14,7 @@ set (LIBRARY_PL operators.pl option.pl pairs.pl + plunit.pl predicate_options.pl predopts.pl prolog_clause.pl @@ -26,6 +28,7 @@ set (LIBRARY_PL settings.pl shlib.pl thread_pool.pl + unix.pl url.pl utf8.pl win_menu.pl @@ -38,7 +41,3 @@ set (LIBRARY_PL install(FILES ${LIBRARY_PL} DESTINATION ${libpl} ) - - - - diff --git a/swi/library/debug.pl b/swi/library/debug.pl index cc4e40262..bae82edee 100644 --- a/swi/library/debug.pl +++ b/swi/library/debug.pl @@ -52,15 +52,15 @@ /*:- use_module(library(prolog_stack)).*/ % We use the autoloader if needed -:- if(current_prolog_flag(dialect, yap)). +%:- if(current_prolog_flag(dialect, yap)). :- use_module(library(hacks), [stack_dump/1]). -% this is as good as I can do. +% this is as good as I can do. backtrace(N) :- stack_dump(N). -:- endif. +%:- endif. %:- set_prolog_flag(generate_debug_info, false). @@ -258,7 +258,7 @@ print_debug(Topic, _To, Format, Args) :- prolog:debug_print_hook(Topic, Format, Args), !. print_debug(_, [], _, _) :- !. print_debug(Topic, To, Format, Args) :- - phrase('$messages':translate_message(debug(Format, Args)), Lines), + phrase('$messages':translate_message(debug(Format, Args), warning), Lines), ( member(T, To), debug_output(T, Stream), print_message_lines(Stream, kind(debug(Topic)), Lines), diff --git a/swi/library/error.pl b/swi/library/error.pl new file mode 100644 index 000000000..30885f541 --- /dev/null +++ b/swi/library/error.pl @@ -0,0 +1 @@ +:- module( error, []). diff --git a/swi/library/plunit.pl b/swi/library/plunit.pl new file mode 100644 index 000000000..d0e20a312 --- /dev/null +++ b/swi/library/plunit.pl @@ -0,0 +1,1730 @@ +/* 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 + ]). + +/** 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 :, 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. diff --git a/swi/library/unix.pl b/swi/library/unix.pl new file mode 100644 index 000000000..08268f0bb --- /dev/null +++ b/swi/library/unix.pl @@ -0,0 +1,3 @@ +:- module( unix, [pipe/2] ). + +pipe(Inp, Out) :- open_pipe_stream(Inp, Out).