core/generic/generic-tests.factor

   1 USING: alien arrays definitions generic generic.standard
   2 generic.math assocs hashtables io kernel math namespaces parser
   3 prettyprint sequences strings tools.test vectors words
   4 quotations classes classes.algebra continuations layouts
   5 classes.union sorting compiler.units ;
   6 IN: generic.tests
   7
   8 GENERIC: foobar ( x -- y )
   9 M: object foobar drop "Hello world" ;
  10 M: fixnum foobar drop "Goodbye cruel world" ;
  11
  12 GENERIC: class-of ( x -- y )
  13
  14 M: fixnum class-of drop "fixnum" ;
  15 M: word   class-of drop "word"   ;
  16
  17 [ "fixnum" ] [ 5 class-of ] unit-test
  18 [ "word" ] [ \ class-of class-of ] unit-test
  19 [ 3.4 class-of ] must-fail
  20
  21 [ "Hello world" ] [ 4 foobar foobar ] unit-test
  22 [ "Goodbye cruel world" ] [ 4 foobar ] unit-test
  23
  24 ! Testing unions
  25 UNION: funnies quotation float complex ;
  26
  27 GENERIC: funny ( x -- y )
  28 M: funnies funny drop 2 ;
  29 M: object funny drop 0 ;
  30
  31 [ 2 ] [ [ { } ] funny ] unit-test
  32 [ 0 ] [ { } funny ] unit-test
  33
  34 PREDICATE: very-funny < funnies number? ;
  35
  36 GENERIC: gooey ( x -- y )
  37 M: very-funny gooey sq ;
  38
  39 [ 0.25 ] [ 0.5 gooey ] unit-test
  40
  41 GENERIC: empty-method-test ( x -- y )
  42 M: object empty-method-test ;
  43 TUPLE: for-arguments-sake ;
  44 C: <for-arguments-sake> for-arguments-sake
  45
  46 M: for-arguments-sake empty-method-test drop "Hi" ;
  47
  48 TUPLE: another-one ;
  49 C: <another-one> another-one
  50
  51 [ "Hi" ] [ <for-arguments-sake> empty-method-test empty-method-test ] unit-test
  52 [ T{ another-one f } ] [ <another-one> empty-method-test ] unit-test
  53
  54 ! Weird bug
  55 GENERIC: stack-underflow ( x y -- )
  56 M: object stack-underflow 2drop ;
  57 M: word stack-underflow 2drop ;
  58
  59 GENERIC: union-containment ( x -- y )
  60 M: integer union-containment drop 1 ;
  61 M: number union-containment drop 2 ;
  62
  63 [ 1 ] [ 1 union-containment ] unit-test
  64 [ 2 ] [ 1.0 union-containment ] unit-test
  65
  66 ! Testing recovery from bad method definitions
  67 "IN: generic.tests GENERIC: unhappy ( x -- x )" eval
  68 [
  69     "IN: generic.tests M: dictionary unhappy ;" eval
  70 ] must-fail
  71 [ ] [ "IN: generic.tests GENERIC: unhappy ( x -- x )" eval ] unit-test
  72
  73 GENERIC# complex-combination 1 ( a b -- c )
  74 M: string complex-combination drop ;
  75 M: object complex-combination nip ;
  76
  77 [ "hi" ] [ "hi" 3 complex-combination ] unit-test
  78 [ "hi" ] [ 3 "hi" complex-combination ] unit-test
  79
  80 TUPLE: shit ;
  81
  82 M: shit complex-combination 2array ;
  83 [ { T{ shit f } 5 } ] [ T{ shit f } 5 complex-combination ] unit-test
  84
  85 [ t ] [ \ complex-combination generic? >boolean ] unit-test
  86
  87 GENERIC: big-generic-test ( x -- x y )
  88 M: fixnum big-generic-test "fixnum" ;
  89 M: bignum big-generic-test "bignum" ;
  90 M: ratio big-generic-test "ratio" ;
  91 M: string big-generic-test "string" ;
  92 M: shit big-generic-test "shit" ;
  93
  94 TUPLE: delegating ;
  95
  96 [ T{ shit f } "shit" ] [ T{ shit f } big-generic-test ] unit-test
  97 [ T{ shit f } "shit" ] [ T{ delegating T{ shit f } } big-generic-test ] unit-test
  98
  99 [ t ] [ \ + math-generic? ] unit-test
 100
 101 ! Test math-combination
 102 [ [ [ >float ] dip ] ] [ \ real \ float math-upgrade ] unit-test
 103 [ [ >float ] ] [ \ float \ real math-upgrade ] unit-test
 104 [ [ [ >bignum ] dip ] ] [ \ fixnum \ bignum math-upgrade ] unit-test
 105 [ [ >float ] ] [ \ float \ integer math-upgrade ] unit-test
 106 [ number ] [ \ number \ float math-class-max ] unit-test
 107 [ float ] [ \ real \ float math-class-max ] unit-test
 108 [ fixnum ] [ \ fixnum \ null math-class-max ] unit-test
 109
 110 [ t ] [ { hashtable equal? } method-spec? ] unit-test
 111 [ f ] [ { word = } method-spec? ] unit-test
 112
 113 ! Regression
 114 TUPLE: first-one ;
 115 TUPLE: second-one ;
 116 UNION: both first-one union-class ;
 117
 118 GENERIC: wii ( x -- y )
 119 M: both wii drop 3 ;
 120 M: second-one wii drop 4 ;
 121 M: tuple-class wii drop 5 ;
 122 M: integer wii drop 6 ;
 123
 124 [ 3 ] [ T{ first-one } wii ] unit-test
 125
 126 GENERIC: tag-and-f ( x -- x x )
 127
 128 M: fixnum tag-and-f 1 ;
 129
 130 M: bignum tag-and-f 2 ;
 131
 132 M: float tag-and-f 3 ;
 133
 134 M: f tag-and-f 4 ;
 135
 136 [ f 4 ] [ f tag-and-f ] unit-test
 137
 138 [ 3.4 3 ] [ 3.4 tag-and-f ] unit-test
 139
 140 ! Issues with forget
 141 GENERIC: generic-forget-test-1
 142
 143 M: integer generic-forget-test-1 / ;
 144
 145 [ t ] [
 146     \ / usage [ word? ] filter
 147     [ word-name "generic-forget-test-1/integer" = ] contains?
 148 ] unit-test
 149
 150 [ ] [
 151     [ \ generic-forget-test-1 forget ] with-compilation-unit
 152 ] unit-test
 153
 154 [ f ] [
 155     \ / usage [ word? ] filter
 156     [ word-name "generic-forget-test-1/integer" = ] contains?
 157 ] unit-test
 158
 159 GENERIC: generic-forget-test-2
 160
 161 M: sequence generic-forget-test-2 = ;
 162
 163 [ t ] [
 164     \ = usage [ word? ] filter
 165     [ word-name "generic-forget-test-2/sequence" = ] contains?
 166 ] unit-test
 167
 168 [ ] [
 169     [ { sequence generic-forget-test-2 } forget ] with-compilation-unit
 170 ] unit-test
 171
 172 [ f ] [
 173     \ = usage [ word? ] filter
 174     [ word-name "generic-forget-test-2/sequence" = ] contains?
 175 ] unit-test
 176
 177 GENERIC: generic-forget-test-3
 178
 179 M: f generic-forget-test-3 ;
 180
 181 [ ] [ \ f \ generic-forget-test-3 method "m" set ] unit-test
 182
 183 [ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
 184
 185 [ ] [ "IN: generic.tests M: f generic-forget-test-3 ;" eval ] unit-test
 186
 187 [ ] [ [ "m" get forget ] with-compilation-unit ] unit-test
 188
 189 [ f ] [ f generic-forget-test-3 ] unit-test
 190
 191 : a-word ;
 192
 193 GENERIC: a-generic
 194
 195 M: integer a-generic a-word ;
 196
 197 [ ] [ \ integer \ a-generic method "m" set ] unit-test
 198
 199 [ t ] [ "m" get \ a-word usage memq? ] unit-test
 200
 201 [ ] [ "IN: generic.tests : a-generic ;" eval ] unit-test
 202
 203 [ f ] [ "m" get \ a-word usage memq? ] unit-test