core/classes/predicate/predicate-tests.factor

   1 USING: math tools.test classes.algebra words kernel sequences assocs
   2 accessors eval definitions compiler.units generic strings classes
   3 generic.single ;
   4 IN: classes.predicate.tests
   5
   6 PREDICATE: negative < integer 0 < ;
   7 PREDICATE: positive < integer 0 > ;
   8
   9 { t } [ negative integer class< ] unit-test
  10 { t } [ positive integer class< ] unit-test
  11 { f } [ integer negative class< ] unit-test
  12 { f } [ integer positive class< ] unit-test
  13 { f } [ negative negative class< ] unit-test
  14 { f } [ positive negative class< ] unit-test
  15
  16 GENERIC: abs ( n -- n )
  17 M: integer abs ;
  18 M: negative abs -1 * ;
  19 M: positive abs ;
  20
  21 { 10 } [ -10 abs ] unit-test
  22 { 10 } [ 10 abs ] unit-test
  23 { 0 } [ 0 abs ] unit-test
  24
  25 ! Bug report from Bruno Deferrari
  26 TUPLE: tuple-a slot ;
  27 TUPLE: tuple-b < tuple-a ;
  28
  29 PREDICATE: tuple-c < tuple-b slot>> ;
  30
  31 GENERIC: ptest ( tuple -- x )
  32 M: tuple-a ptest drop tuple-a ;
  33 M: tuple-c ptest drop tuple-c ;
  34
  35 { tuple-a } [ tuple-b new ptest ] unit-test
  36 { tuple-c } [ tuple-b new t >>slot ptest ] unit-test
  37
  38 PREDICATE: tuple-d < tuple-a slot>> ;
  39
  40 GENERIC: ptest' ( tuple -- x )
  41 M: tuple-a ptest' drop tuple-a ;
  42 M: tuple-d ptest' drop tuple-d ;
  43
  44 { tuple-a } [ tuple-b new ptest' ] unit-test
  45 { tuple-d } [ tuple-b new t >>slot ptest' ] unit-test
  46
  47 PREDICATE: bad-inheritance-predicate < string ;
  48 [
  49     "IN: classes.predicate.tests PREDICATE: bad-inheritance-predicate < bad-inheritance-predicate ;" eval( -- )
  50 ] [ error>> bad-inheritance? ] must-fail-with
  51
  52 PREDICATE: bad-inheritance-predicate2 < string ;
  53 PREDICATE: bad-inheritance-predicate3 < bad-inheritance-predicate2 ;
  54 [
  55     "IN: classes.predicate.tests PREDICATE: bad-inheritance-predicate2 < bad-inheritance-predicate3 ;" eval( -- )
  56 ] [ error>> bad-inheritance? ] must-fail-with
  57
  58 ! This must not fail
  59 PREDICATE: tup < string ;
  60 UNION: u tup ;
  61
  62 { } [ "IN: classes.predicate.tests PREDICATE: u < tup ;" eval( -- ) ] unit-test
  63
  64 ! Changing the metaclass of the predicate superclass should work
  65 GENERIC: change-meta-test ( a -- b )
  66
  67 TUPLE: change-meta-test-class length ;
  68
  69 PREDICATE: change-meta-test-predicate < change-meta-test-class length>> 2 > ;
  70
  71 M: change-meta-test-predicate change-meta-test length>> ;
  72
  73 { f } [ \ change-meta-test "methods" word-prop assoc-empty? ] unit-test
  74
  75 [ T{ change-meta-test-class f 0 } change-meta-test ] [ no-method? ] must-fail-with
  76 { 7 } [ T{ change-meta-test-class f 7 } change-meta-test ] unit-test
  77
  78 { } [ "IN: classes.predicate.tests USE: arrays UNION: change-meta-test-class array ;" eval( -- ) ] unit-test
  79
  80 ! Should not have changed
  81 { change-meta-test-class } [ change-meta-test-predicate superclass ] unit-test
  82 [ { } change-meta-test ] [ no-method? ] must-fail-with
  83 { 4 } [ { 1 2 3 4 } change-meta-test ] unit-test
  84
  85 { } [ [ \ change-meta-test-class forget-class ] with-compilation-unit ] unit-test
  86
  87 { f } [ change-meta-test-predicate class? ] unit-test
  88
  89 { t } [ \ change-meta-test "methods" word-prop assoc-empty? ] unit-test