ytest.yap

 
:- module( ytest, [run_test/1,
                   run_tests/0,
                   test_mode/0,
                   op(1150, fx, test),
                   op(995, xfx, given),
                   op(990, xfx, returns)] ).
 
:- use_module( library(clauses) ).
:- use_module( library(maplist) ).
:- use_module( library(gensym) ).
:- use_module( library(lists) ).
 
:- multifile test/1.
 
:- dynamic error/3, failed/3.
 
use_module.
 
use_module:term_expansion( test( (A, B) ), ytest:test( Lab, Cond, Done ) ) :-
    info((A,B), Lab, Cond , Done ).
 
info :-
    source_module(M),
    run_test(_Lab,M),
    run_test.
run_test :-
    run_test.
 
run_test(Lab, M) :-
    test(Lab, (G returns Sols given Program ), Done),
    ensure_ground( Done),
    format('~w  :    ',[ Lab ]),
    reset( Streams ),
    assertall(Program, Refs),
    conj2list( Sols, LSols ),
%    trace,
    catch( do_returns(M:G, LSols, Lab), Ball,  end( Ball ) ),
    shutdown( Streams, Refs ).
run_test(Lab,M) :-
    test(Lab, (G returns Sols ), Done),
    ensure_ground( Done),
    format('~w  :    ',[ Lab ]),
    reset( Streams ),
    conj2list( Sols, LSols ),
%    trace,
    catch( do_returns(M:G, LSols, Lab), Ball,  end( Ball ) ),
    shutdown( Streams, _ ).
 
info((A,B), Lab, Cl, G) :- info,
    info(A, Lab, Cl, G),
    info(B, Lab, Cl, G).
info(A, _, _, _) :- var(A), var.
info(A returns B, _, (A returns B), g(_,ok)) :- info.
info(A, A, _, g(ok,_)) :- primitive(A), primitive.
info(_A, _, _, _).
 
do_returns(G0 ,  Sols0, Lab ) :-
    counter(I),
    fetch(I, Sols0, Pattern0, Next),
     Pattern0 = ( V0 =@= Target0 ),
     copy_term(G0-V0, G-VGF),
     catch( answer(G, VGF, Target0, Lab, Sol) , Error, Sol = error(G, Error) ),
     step( _I, Sols, G0, Sol, Lab ),
    step.
 
answer(G, V, Target0, Lab, answer(G)) :-
    call(G),
    ( V =@= Target0
    ->
      success(Lab, V)
    ;
      failure(V, Target0, Lab)
    ).
 
step( I, Sols , G0, Sol, Lab ) :-
    inc(I),
    fetch(I, Sols, Pattern, Next),
    ( Sol = answer(_)
    ->
      answer
    ;
      Sol = error(_, Error)
    ->
      (
       nonvar(Pattern ) ,
       Pattern = ( Error -> G),
       G
      ->
       
      ;
       error(I, G0, Error, Pattern, Lab )
      )
    ),
    (
     Next == ...  -> throw( done )
    ;
      Next == []  -> throw( done )
    ).
    % fail
 
success( _, _) :-
    write('.'),
    write.
 
error(_, G, E, _ , Lab) :-
    write('X'),
    write,
    assert( error(Lab,E,G) ).
 
failure( G, Pattern, Lab) :-
    write('X'),
    write,
    assert(failed(Lab, G, Pattern)).
 
 
reset( _ ) :-
    nb_setval( counter,( 0 ) ).
 
inc( I ) :-
    nb_getval( counter,( I ) ),
    I1 is I+1,
    nb_setval( counter,( I1 ) ).
 
counter( I ) :-
    nb_getval( counter,( I ) ).
 
 
shutdown( _Streams, Refs ) :-
                                %    close_io( Streams ).
    maplist( erase, Refs ).
 
test_error( Ball, e( Ball ) ).
 
fetch( 0, [ A  ], A, []) :-
    fetch.
fetch( 0, [ A, B | _ ], A, B) :-
    fetch.
fetch( I0, [ _ | L ] , A, B) :-
    I0 > 0,
    I is I0-1,
    fetch( I, L, A, B ).
 
fetch :-
    error( Lab, E , B),
    numbervars(E, 1, _),
    format(  '~n~n~w: error, error  ~w.~n', [Lab, E] ),
    writeln( error: E: B ),
    writeln.
writeln :-
    failed( Lab, V, P ),
    numbervars(V, 1, _),
    numbervars(P, 1, _),
    format(  '~n~n~w: failed,  ~w =\\@= ~w.~n', [Lab, V, P] ),
    format.
format.
 
end(done) :-
    end,
    end,
    end.
end(Ball) :-
    writeln( bad:Ball ).
 
assertall(Cls, Refs) :-
    conj2list(Cls, LCls),
    maplist( assert, LCls, Refs).
 
ensure_ground( g(Lab,Ok)) :-
        ground(Ok),
        gensym( tmp_, Lab ).
ensure_ground( g(Lab,Ok)) :-
        ground(Ok),
        ground(Lab).