core/classes/classes-tests.factor

   1 USING: assocs classes classes.private compiler.units definitions
   2 eval generic io.streams.string kernel math multiline namespaces
   3 parser sequences sets sorting tools.test vocabs words ;
   4 IN: classes.tests
   5
   6 { t } [ 3 object instance? ] unit-test
   7 { t } [ 3 fixnum instance? ] unit-test
   8 { f } [ 3 float instance? ] unit-test
   9 { t } [ 3 number instance? ] unit-test
  10 { f } [ 3 null instance? ] unit-test
  11
  12 ! Regression
  13 GENERIC: method-forget-test ( obj -- obj )
  14 TUPLE: method-forget-class ;
  15 M: method-forget-class method-forget-test ;
  16
  17 { f } [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test
  18 { } [ [ \ method-forget-class forget ] with-compilation-unit ] unit-test
  19 { t } [ \ method-forget-test "methods" word-prop assoc-empty? ] unit-test
  20
  21 { { } { } } [
  22     all-words [ class? ] filter
  23     implementors-map get keys
  24     [ natural-sort ] bi@
  25     [ diff ] [ swap diff ] 2bi
  26 ] unit-test
  27
  28 ! Long-standing problem
  29 USE: multiline
  30
  31 ! So the user has some code...
  32 { } [
  33     "IN: classes.test.a
  34     GENERIC: g ( a -- b )
  35     TUPLE: x ;
  36     M: x g ;
  37     TUPLE: z < x ;" <string-reader>
  38     "class-intersect-no-method-a" parse-stream drop
  39 ] unit-test
  40
  41 ! Note that q inlines M: x g ;
  42 { } [
  43     "IN: classes.test.b
  44     USE: classes.test.a
  45     USE: kernel
  46     : q ( -- b ) z new g ;" <string-reader>
  47     "class-intersect-no-method-b" parse-stream drop
  48 ] unit-test
  49
  50 ! Now, the user removes the z class and adds a method,
  51 { } [
  52     "IN: classes.test.a
  53     GENERIC: g ( a -- b )
  54     TUPLE: x ;
  55     M: x g ;
  56     TUPLE: j ;
  57     M: j g ;" <string-reader>
  58     "class-intersect-no-method-a" parse-stream drop
  59 ] unit-test
  60
  61 ! And changes the definition of q
  62 { } [
  63     "IN: classes.test.b
  64     USE: classes.test.a
  65     USE: kernel
  66     : q ( -- b ) j new g ;" <string-reader>
  67     "class-intersect-no-method-b" parse-stream drop
  68 ] unit-test
  69
  70 ! Similar problem, but with anonymous classes
  71 { } [
  72     "IN: classes.test.c
  73     USE: kernel
  74     GENERIC: g ( a -- b )
  75     M: object g ;
  76     TUPLE: z ;" <string-reader>
  77     "class-intersect-no-method-c" parse-stream drop
  78 ] unit-test
  79
  80 { } [
  81     "IN: classes.test.d
  82     USE: classes.test.c
  83     USE: kernel
  84     : q ( a -- b ) dup z? [ g ] unless ;" <string-reader>
  85     "class-intersect-no-method-d" parse-stream drop
  86 ] unit-test
  87
  88 ! Now, the user removes the z class and adds a method,
  89 { } [
  90     "IN: classes.test.c
  91     USE: kernel
  92     GENERIC: g ( a -- b )
  93     M: object g ;
  94     TUPLE: j ;
  95     M: j g ;" <string-reader>
  96     "class-intersect-no-method-c" parse-stream drop
  97 ] unit-test
  98
  99 ! Forget the above crap
 100 [
 101     { "classes.test.a" "classes.test.b" "classes.test.c" "classes.test.d" }
 102     [ forget-vocab ] each
 103 ] with-compilation-unit
 104
 105 TUPLE: forgotten-predicate-test ;
 106
 107 { } [ [ \ forgotten-predicate-test forget ] with-compilation-unit ] unit-test
 108 { f } [ \ forgotten-predicate-test? predicate? ] unit-test
 109
 110 GENERIC: generic-predicate? ( a -- b )
 111
 112 { } [ "IN: classes.tests TUPLE: generic-predicate ;" eval( -- ) ] unit-test
 113
 114 { f } [ \ generic-predicate? generic? ] unit-test
 115
 116 ! all-contained-classes
 117 {
 118     { maybe{ integer } integer fixnum bignum }
 119 } [
 120     { maybe{ integer } } all-contained-classes
 121 ] unit-test
 122
 123 ! contained-classes
 124 {
 125     { fixnum bignum }
 126     { integer }
 127 } [
 128     integer contained-classes
 129     maybe{ integer } contained-classes
 130 ] unit-test
 131
 132 ! make-class-props
 133 {
 134     H{
 135         { "superclass" f }
 136         { "members" { fixnum } }
 137         { "metaclass" f }
 138         { "participants" { } }
 139     }
 140 } [
 141     f { fixnum } { } f  make-class-props
 142 ] unit-test
 143
 144 { "test" } [ "test" sequence check-instance ] unit-test
 145 [ "test" fixnum check-instance ] [ not-an-instance? ] must-fail-with