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