core/generic/standard/standard-tests.factor

   1 IN: generic.standard.tests
   2 USING: tools.test math math.functions math.constants
   3 generic.standard strings sequences arrays kernel accessors words
   4 specialized-arrays.double byte-arrays bit-arrays parser
   5 namespaces make quotations stack-checker vectors growable
   6 hashtables sbufs prettyprint byte-vectors bit-vectors
   7 specialized-vectors.double definitions generic sets graphs assocs
   8 grouping ;
   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 ( n -- 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: my-tuple-hook my-var ( -- x )
 253
 254 M: sequence my-tuple-hook my-hook ;
 255
 256 TUPLE: m-t-h-a ;
 257
 258 M: m-t-h-a my-tuple-hook "foo" ;
 259
 260 TUPLE: m-t-h-b < m-t-h-a ;
 261
 262 M: m-t-h-b my-tuple-hook "bar" ;
 263
 264 [ f ] [
 265     \ my-tuple-hook [ "engines" word-prop ] keep prefix
 266     [ 1quotation infer ] map all-equal?
 267 ] unit-test
 268
 269 HOOK: call-next-hooker my-var ( -- x )
 270
 271 M: sequence call-next-hooker "sequence" ;
 272
 273 M: array call-next-hooker call-next-method "array " prepend ;
 274
 275 M: vector call-next-hooker call-next-method "vector " prepend ;
 276
 277 M: growable call-next-hooker call-next-method "growable " prepend ;
 278
 279 [ "vector growable sequence" ] [
 280     V{ } my-var [ call-next-hooker ] with-variable
 281 ] unit-test
 282
 283 GENERIC: no-stack-effect-decl
 284
 285 M: hashtable no-stack-effect-decl ;
 286 M: vector no-stack-effect-decl ;
 287 M: sbuf no-stack-effect-decl ;
 288
 289 [ ] [ \ no-stack-effect-decl see ] unit-test
 290
 291 [ ] [ \ no-stack-effect-decl def>> . ] unit-test
 292
 293 ! Cross-referencing with generic words
 294 TUPLE: xref-tuple-1 ;
 295 TUPLE: xref-tuple-2 < xref-tuple-1 ;
 296
 297 : (xref-test) ( obj -- ) drop ;
 298
 299 GENERIC: xref-test ( obj -- )
 300
 301 M: xref-tuple-1 xref-test (xref-test) ;
 302 M: xref-tuple-2 xref-test (xref-test) ;
 303
 304 [ t ] [
 305     \ xref-test
 306     \ xref-tuple-1 \ xref-test method [ usage unique ] closure key?
 307 ] unit-test
 308
 309 [ t ] [
 310     \ xref-test
 311     \ xref-tuple-2 \ xref-test method [ usage unique ] closure key?
 312 ] unit-test
 313
 314 [ t ] [
 315     { } \ nth effective-method nip \ sequence \ nth method eq?
 316 ] unit-test
 317
 318 [ t ] [
 319     \ + \ nth effective-method nip dup \ nth "default-method" word-prop eq? and
 320 ] unit-test