USING: math tools.test classes.algebra words kernel sequences assocs
accessors eval definitions compiler.units generic strings classes
generic.single ;
IN: classes.predicate.tests

PREDICATE: negative < integer 0 < ;
PREDICATE: positive < integer 0 > ;

[ t ] [ negative integer class< ] unit-test
[ t ] [ positive integer class< ] unit-test
[ f ] [ integer negative class< ] unit-test
[ f ] [ integer positive class< ] unit-test
[ f ] [ negative negative class< ] unit-test
[ f ] [ positive negative class< ] unit-test

GENERIC: abs ( n -- n )
M: integer abs ;
M: negative abs -1 * ;
M: positive abs ;

[ 10 ] [ -10 abs ] unit-test
[ 10 ] [ 10 abs ] unit-test
[ 0 ] [ 0 abs ] unit-test

! Bug report from Bruno Deferrari
TUPLE: tuple-a slot ;
TUPLE: tuple-b < tuple-a ;

PREDICATE: tuple-c < tuple-b slot>> ;

GENERIC: ptest ( tuple -- x )
M: tuple-a ptest drop tuple-a ;
M: tuple-c ptest drop tuple-c ;

[ tuple-a ] [ tuple-b new ptest ] unit-test
[ tuple-c ] [ tuple-b new t >>slot ptest ] unit-test

PREDICATE: tuple-d < tuple-a slot>> ;

GENERIC: ptest' ( tuple -- x )
M: tuple-a ptest' drop tuple-a ;
M: tuple-d ptest' drop tuple-d ;

[ tuple-a ] [ tuple-b new ptest' ] unit-test
[ tuple-d ] [ tuple-b new t >>slot ptest' ] unit-test

PREDICATE: bad-inheritance-predicate < string ;
[
    "IN: classes.predicate.tests PREDICATE: bad-inheritance-predicate < bad-inheritance-predicate ;" eval( -- )
] [ error>> bad-inheritance? ] must-fail-with

PREDICATE: bad-inheritance-predicate2 < string ;
PREDICATE: bad-inheritance-predicate3 < bad-inheritance-predicate2 ;
[
    "IN: classes.predicate.tests PREDICATE: bad-inheritance-predicate2 < bad-inheritance-predicate3 ;" eval( -- )
] [ error>> bad-inheritance? ] must-fail-with

! This must not fail
PREDICATE: tup < string ;
UNION: u tup ;

[ ] [ "IN: classes.predicate.tests PREDICATE: u < tup ;" eval( -- ) ] unit-test

! Changing the metaclass of the predicate superclass should work
GENERIC: change-meta-test ( a -- b )

TUPLE: change-meta-test-class length ;

PREDICATE: change-meta-test-predicate < change-meta-test-class length>> 2 > ;

M: change-meta-test-predicate change-meta-test length>> ;

[ f ] [ \ change-meta-test "methods" word-prop assoc-empty? ] unit-test

[ T{ change-meta-test-class f 0 } change-meta-test ] [ no-method? ] must-fail-with
[ 7 ] [ T{ change-meta-test-class f 7 } change-meta-test ] unit-test

[ ] [ "IN: classes.predicate.tests USE: arrays UNION: change-meta-test-class array ;" eval( -- ) ] unit-test

! Should not have changed
[ change-meta-test-class ] [ change-meta-test-predicate superclass ] unit-test
[ { } change-meta-test ] [ no-method? ] must-fail-with
[ 4 ] [ { 1 2 3 4 } change-meta-test ] unit-test

[ ] [ [ \ change-meta-test-class forget-class ] with-compilation-unit ] unit-test

[ f ] [ change-meta-test-predicate class? ] unit-test

[ t ] [ \ change-meta-test "methods" word-prop assoc-empty? ] unit-test