core/generic/single/single-tests.factor

   1 USING: tools.test math math.functions math.constants
   2 generic.standard generic.single strings sequences arrays kernel
   3 accessors words byte-arrays bit-arrays parser namespaces make
   4 quotations stack-checker vectors growable hashtables sbufs
   5 prettyprint byte-vectors bit-vectors specialized-vectors
   6 definitions generic sets graphs assocs grouping see eval ;
   7 SPECIALIZED-VECTOR: double
   8 IN: generic.single.tests
   9
  10 GENERIC: lo-tag-test ( obj -- obj' )
  11
  12 M: integer lo-tag-test 3 + ;
  13
  14 M: float lo-tag-test 4 - ;
  15
  16 M: rational lo-tag-test 2 - ;
  17
  18 M: complex lo-tag-test sq ;
  19
  20 [ 8 ] [ 5 >bignum lo-tag-test ] unit-test
  21 [ 0.0 ] [ 4.0 lo-tag-test ] unit-test
  22 [ -1/2 ] [ 1+1/2 lo-tag-test ] unit-test
  23 [ -16 ] [ C{ 0 4 } lo-tag-test ] unit-test
  24
  25 GENERIC: hi-tag-test ( obj -- obj' )
  26
  27 M: string hi-tag-test ", in bed" append ;
  28
  29 M: integer hi-tag-test 3 + ;
  30
  31 M: array hi-tag-test [ hi-tag-test ] map ;
  32
  33 M: sequence hi-tag-test reverse ;
  34
  35 [ B{ 3 2 1 } ] [ B{ 1 2 3 } hi-tag-test ] unit-test
  36
  37 [ { 6 9 12 } ] [ { 3 6 9 } hi-tag-test ] unit-test
  38
  39 [ "i like monkeys, in bed" ] [ "i like monkeys" hi-tag-test ] unit-test
  40
  41 TUPLE: shape ;
  42
  43 TUPLE: abstract-rectangle < shape width height ;
  44
  45 TUPLE: rectangle < abstract-rectangle ;
  46
  47 C: <rectangle> rectangle
  48
  49 TUPLE: parallelogram < abstract-rectangle skew ;
  50
  51 C: <parallelogram> parallelogram
  52
  53 TUPLE: circle < shape radius ;
  54
  55 C: <circle> circle
  56
  57 GENERIC: area ( shape -- n )
  58
  59 M: abstract-rectangle area [ width>> ] [ height>> ] bi * ;
  60
  61 M: circle area radius>> sq pi * ;
  62
  63 [ 12 ] [ 4 3 <rectangle> area ] unit-test
  64 [ 12 ] [ 4 3 2 <parallelogram> area ] unit-test
  65 [ t ] [ 2 <circle> area 4 pi * = ] unit-test
  66
  67 GENERIC: perimiter ( shape -- n )
  68
  69 : rectangle-perimiter ( l w -- n ) + 2 * ;
  70
  71 M: rectangle perimiter
  72     [ width>> ] [ height>> ] bi
  73     rectangle-perimiter ;
  74
  75 : hypotenuse ( a b -- c ) [ sq ] bi@ + sqrt ;
  76
  77 M: parallelogram perimiter
  78     [ width>> ]
  79     [ [ height>> ] [ skew>> ] bi hypotenuse ] bi
  80     rectangle-perimiter ;
  81
  82 M: circle perimiter 2 * pi * ;
  83
  84 [ 14 ] [ 4 3 <rectangle> perimiter ] unit-test
  85 [ 30.0 ] [ 10 4 3 <parallelogram> perimiter ] unit-test
  86
  87 GENERIC: big-mix-test ( obj -- obj' )
  88
  89 M: object big-mix-test drop "object" ;
  90
  91 M: tuple big-mix-test drop "tuple" ;
  92
  93 M: integer big-mix-test drop "integer" ;
  94
  95 M: float big-mix-test drop "float" ;
  96
  97 M: complex big-mix-test drop "complex" ;
  98
  99 M: string big-mix-test drop "string" ;
 100
 101 M: array big-mix-test drop "array" ;
 102
 103 M: sequence big-mix-test drop "sequence" ;
 104
 105 M: rectangle big-mix-test drop "rectangle" ;
 106
 107 M: parallelogram big-mix-test drop "parallelogram" ;
 108
 109 M: circle big-mix-test drop "circle" ;
 110
 111 [ "integer" ] [ 3 big-mix-test ] unit-test
 112 [ "float" ] [ 5.0 big-mix-test ] unit-test
 113 [ "complex" ] [ -1 sqrt big-mix-test ] unit-test
 114 [ "sequence" ] [ double-array{ 1.0 2.0 3.0 } big-mix-test ] unit-test
 115 [ "sequence" ] [ B{ 1 2 3 } big-mix-test ] unit-test
 116 [ "sequence" ] [ ?{ t f t } big-mix-test ] unit-test
 117 [ "sequence" ] [ SBUF" hello world" big-mix-test ] unit-test
 118 [ "sequence" ] [ V{ "a" "b" } big-mix-test ] unit-test
 119 [ "sequence" ] [ BV{ 1 2 } big-mix-test ] unit-test
 120 [ "sequence" ] [ ?V{ t t f f } big-mix-test ] unit-test
 121 [ "sequence" ] [ double-vector{ -0.3 4.6 } big-mix-test ] unit-test
 122 [ "string" ] [ "hello" big-mix-test ] unit-test
 123 [ "rectangle" ] [ 1 2 <rectangle> big-mix-test ] unit-test
 124 [ "parallelogram" ] [ 10 4 3 <parallelogram> big-mix-test ] unit-test
 125 [ "circle" ] [ 100 <circle> big-mix-test ] unit-test
 126 [ "tuple" ] [ H{ } big-mix-test ] unit-test
 127 [ "object" ] [ \ + big-mix-test ] unit-test
 128
 129 GENERIC: small-lo-tag ( obj -- obj )
 130
 131 M: fixnum small-lo-tag drop "fixnum" ;
 132
 133 M: string small-lo-tag drop "string" ;
 134
 135 M: array small-lo-tag drop "array" ;
 136
 137 M: double-array small-lo-tag drop "double-array" ;
 138
 139 M: byte-array small-lo-tag drop "byte-array" ;
 140
 141 [ "fixnum" ] [ 3 small-lo-tag ] unit-test
 142
 143 [ "double-array" ] [ double-array{ 1.0 } small-lo-tag ] unit-test
 144
 145 ! Testing next-method
 146 TUPLE: person ;
 147
 148 TUPLE: intern < person ;
 149
 150 TUPLE: employee < person ;
 151
 152 TUPLE: tape-monkey < employee ;
 153
 154 TUPLE: manager < employee ;
 155
 156 TUPLE: junior-manager < manager ;
 157
 158 TUPLE: middle-manager < manager ;
 159
 160 TUPLE: senior-manager < manager ;
 161
 162 TUPLE: executive < senior-manager ;
 163
 164 TUPLE: ceo < executive ;
 165
 166 GENERIC: salary ( person -- n )
 167
 168 M: intern salary
 169     #! Intentional mistake.
 170     call-next-method ;
 171
 172 M: employee salary drop 24000 ;
 173
 174 M: manager salary call-next-method 12000 + ;
 175
 176 M: middle-manager salary call-next-method 5000 + ;
 177
 178 M: senior-manager salary call-next-method 15000 + ;
 179
 180 M: executive salary call-next-method 2 * ;
 181
 182 M: ceo salary
 183     #! Intentional error.
 184     drop 5 call-next-method 3 * ;
 185
 186 [ salary ] must-infer
 187
 188 [ 24000 ] [ employee boa salary ] unit-test
 189
 190 [ 24000 ] [ tape-monkey boa salary ] unit-test
 191
 192 [ 36000 ] [ junior-manager boa salary ] unit-test
 193
 194 [ 41000 ] [ middle-manager boa salary ] unit-test
 195
 196 [ 51000 ] [ senior-manager boa salary ] unit-test
 197
 198 [ 102000 ] [ executive boa salary ] unit-test
 199
 200 [ ceo boa salary ]
 201 [ T{ inconsistent-next-method f ceo salary } = ] must-fail-with
 202
 203 [ intern boa salary ]
 204 [ no-next-method? ] must-fail-with
 205
 206 ! Weird shit
 207 TUPLE: a ;
 208 TUPLE: b ;
 209 TUPLE: c ;
 210
 211 UNION: x a b ;
 212 UNION: y a c ;
 213
 214 UNION: z x y ;
 215
 216 GENERIC: funky* ( obj -- )
 217
 218 M: z funky* "z" , drop ;
 219
 220 M: x funky* "x" , call-next-method ;
 221
 222 M: y funky* "y" , call-next-method ;
 223
 224 M: a funky* "a" , call-next-method ;
 225
 226 M: b funky* "b" , call-next-method ;
 227
 228 M: c funky* "c" , call-next-method ;
 229
 230 : funky ( obj -- seq ) [ funky* ] { } make ;
 231
 232 [ { "b" "x" "z" } ] [ T{ b } funky ] unit-test
 233
 234 [ { "c" "y" "z" } ] [ T{ c } funky ] unit-test
 235
 236 [ t ] [
 237     T{ a } funky
 238     { { "a" "x" "z" } { "a" "y" "z" } } member?
 239 ] unit-test
 240
 241 ! Hooks
 242 SYMBOL: my-var
 243 HOOK: my-hook my-var ( -- x )
 244
 245 M: integer my-hook "an integer" ;
 246 M: string my-hook "a string" ;
 247
 248 [ "an integer" ] [ 3 my-var set my-hook ] unit-test
 249 [ "a string" ] [ my-hook my-var set my-hook ] unit-test
 250 [ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with
 251
 252 HOOK: call-next-hooker my-var ( -- x )
 253
 254 M: sequence call-next-hooker "sequence" ;
 255
 256 M: array call-next-hooker call-next-method "array " prepend ;
 257
 258 M: vector call-next-hooker call-next-method "vector " prepend ;
 259
 260 M: growable call-next-hooker call-next-method "growable " prepend ;
 261
 262 [ "vector growable sequence" ] [
 263     V{ } my-var [ call-next-hooker ] with-variable
 264 ] unit-test
 265
 266 [ t ] [
 267     { } \ nth effective-method nip M\ sequence nth eq?
 268 ] unit-test
 269
 270 [ t ] [
 271     \ + \ nth effective-method nip dup \ nth "default-method" word-prop eq? and
 272 ] unit-test
 273
 274 [ ] [ "IN: generic.single.tests GENERIC: xyz ( a -- b )" eval( -- ) ] unit-test
 275 [ ] [ "IN: generic.single.tests MATH: xyz ( a b -- c )" eval( -- ) ] unit-test
 276
 277 [ f ] [ "xyz" "generic.single.tests" lookup pic-def>> ] unit-test
 278 [ f ] [ "xyz" "generic.single.tests" lookup "decision-tree" word-prop ] unit-test
 279
 280 ! Corner case
 281 [ "IN: generic.single.tests GENERIC# broken-generic# -1 ( a -- b )" eval( -- ) ]
 282 [ error>> bad-dispatch-position? ]
 283 must-fail-with