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 continuations layouts classes.union sorting ;
   5 IN: temporary
   6
   7 GENERIC: foobar ( x -- y )
   8 M: object foobar drop "Hello world" ;
   9 M: fixnum foobar drop "Goodbye cruel world" ;
  10
  11 GENERIC: class-of ( x -- y )
  12
  13 M: fixnum class-of drop "fixnum" ;
  14 M: word   class-of drop "word"   ;
  15
  16 [ "fixnum" ] [ 5 class-of ] unit-test
  17 [ "word" ] [ \ class-of class-of ] unit-test
  18 [ 3.4 class-of ] unit-test-fails
  19
  20 [ "Hello world" ] [ 4 foobar foobar ] unit-test
  21 [ "Goodbye cruel world" ] [ 4 foobar ] unit-test
  22
  23 GENERIC: bool>str ( x -- y )
  24 M: general-t bool>str drop "true" ;
  25 M: f bool>str drop "false" ;
  26
  27 : str>bool
  28     H{
  29         { "true" t }
  30         { "false" f }
  31     } at ;
  32
  33 [ t ] [ t bool>str str>bool ] unit-test
  34 [ f ] [ f bool>str str>bool ] unit-test
  35
  36 ! Testing unions
  37 UNION: funnies quotation ratio complex ;
  38
  39 GENERIC: funny ( x -- y )
  40 M: funnies funny drop 2 ;
  41 M: object funny drop 0 ;
  42
  43 [ 2 ] [ [ { } ] funny ] unit-test
  44 [ 0 ] [ { } funny ] unit-test
  45
  46 PREDICATE: funnies very-funny number? ;
  47
  48 GENERIC: gooey ( x -- y )
  49 M: very-funny gooey sq ;
  50
  51 [ 1/4 ] [ 1/2 gooey ] unit-test
  52
  53 DEFER: complement-test
  54 FORGET: complement-test
  55 GENERIC: complement-test ( x -- y )
  56
  57 M: f         complement-test drop "f" ;
  58 M: general-t complement-test drop "general-t" ;
  59
  60 [ "general-t" ] [ 5 complement-test ] unit-test
  61 [ "f" ] [ f complement-test ] unit-test
  62
  63 GENERIC: empty-method-test ( x -- y )
  64 M: object empty-method-test ;
  65 TUPLE: for-arguments-sake ;
  66 C: <for-arguments-sake> for-arguments-sake
  67
  68 M: for-arguments-sake empty-method-test drop "Hi" ;
  69
  70 TUPLE: another-one ;
  71 C: <another-one> another-one
  72
  73 [ "Hi" ] [ <for-arguments-sake> empty-method-test empty-method-test ] unit-test
  74 [ T{ another-one f } ] [ <another-one> empty-method-test ] unit-test
  75
  76 ! Weird bug
  77 GENERIC: stack-underflow ( x y -- )
  78 M: object stack-underflow 2drop ;
  79 M: word stack-underflow 2drop ;
  80
  81 GENERIC: union-containment ( x -- y )
  82 M: integer union-containment drop 1 ;
  83 M: number union-containment drop 2 ;
  84
  85 [ 1 ] [ 1 union-containment ] unit-test
  86 [ 2 ] [ 1.0 union-containment ] unit-test
  87
  88 ! Testing recovery from bad method definitions
  89 "IN: temporary GENERIC: unhappy ( x -- x )" eval
  90 [
  91     "IN: temporary M: dictionary unhappy ;" eval
  92 ] unit-test-fails
  93 [ ] [ "IN: temporary GENERIC: unhappy ( x -- x )" eval ] unit-test
  94
  95 GENERIC# complex-combination 1 ( a b -- c )
  96 M: string complex-combination drop ;
  97 M: object complex-combination nip ;
  98
  99 [ "hi" ] [ "hi" 3 complex-combination ] unit-test
 100 [ "hi" ] [ 3 "hi" complex-combination ] unit-test
 101
 102 TUPLE: shit ;
 103
 104 M: shit complex-combination 2array ;
 105 [ { T{ shit f } 5 } ] [ T{ shit f } 5 complex-combination ] unit-test
 106
 107 [ t ] [ \ complex-combination generic? >boolean ] unit-test
 108
 109 GENERIC: big-generic-test ( x -- x y )
 110 M: fixnum big-generic-test "fixnum" ;
 111 M: bignum big-generic-test "bignum" ;
 112 M: ratio big-generic-test "ratio" ;
 113 M: string big-generic-test "string" ;
 114 M: shit big-generic-test "shit" ;
 115
 116 TUPLE: delegating ;
 117
 118 [ T{ shit f } "shit" ] [ T{ shit f } big-generic-test ] unit-test
 119 [ T{ shit f } "shit" ] [ T{ delegating T{ shit f } } big-generic-test ] unit-test
 120
 121 [ t ] [ \ + math-generic? ] unit-test
 122
 123 [ "SYMBOL: not-a-class C: not-a-class ;" parse ] unit-test-fails
 124
 125 ! Test math-combination
 126 [ [ >r >float r> ] ] [ \ real \ float math-upgrade ] unit-test
 127 [ [ >float ] ] [ \ float \ real math-upgrade ] unit-test
 128 [ [ >r >bignum r> ] ] [ \ fixnum \ bignum math-upgrade ] unit-test
 129 [ [ >float ] ] [ \ float \ integer math-upgrade ] unit-test
 130 [ number ] [ \ number \ float math-class-max ] unit-test
 131 [ float ] [ \ real \ float math-class-max ] unit-test
 132 [ fixnum ] [ \ fixnum \ null math-class-max ] unit-test
 133
 134 [ t ] [ { hashtable equal? } method-spec? ] unit-test
 135 [ f ] [ { word = } method-spec? ] unit-test
 136
 137 ! Regression
 138 TUPLE: first-one ;
 139 TUPLE: second-one ;
 140 UNION: both first-one union-class ;
 141
 142 GENERIC: wii ( x -- y )
 143 M: both wii drop 3 ;
 144 M: second-one wii drop 4 ;
 145 M: tuple-class wii drop 5 ;
 146 M: integer wii drop 6 ;
 147
 148 [ 3 ] [ T{ first-one } wii ] unit-test
 149
 150 ! Hooks
 151 SYMBOL: my-var
 152 HOOK: my-hook my-var ( -- x )
 153
 154 M: integer my-hook "an integer" ;
 155 M: string my-hook "a string" ;
 156
 157 [ "an integer" ] [ 3 my-var set my-hook ] unit-test
 158 [ "a string" ] [ my-hook my-var set my-hook ] unit-test
 159 [ T{ no-method f 1.0 my-hook } ] [
 160     1.0 my-var set [ my-hook ] catch
 161 ] unit-test
 162
 163 GENERIC: tag-and-f ( x -- x x )
 164
 165 M: fixnum tag-and-f 1 ;
 166
 167 M: bignum tag-and-f 2 ;
 168
 169 M: float tag-and-f 3 ;
 170
 171 M: f tag-and-f 4 ;
 172
 173 [ f 4 ] [ f tag-and-f ] unit-test
 174
 175 [ 3.4 3 ] [ 3.4 tag-and-f ] unit-test
 176
 177 ! define-class hashing issue
 178 TUPLE: debug-combination ;
 179
 180 M: debug-combination perform-combination
 181     drop
 182     order [ dup class-hashes ] { } map>assoc sort-keys
 183     1quotation ;
 184
 185 SYMBOL: redefinition-test-generic
 186
 187 redefinition-test-generic T{ debug-combination } define-generic
 188
 189 TUPLE: redefinition-test-tuple ;
 190
 191 "IN: temporary M: redefinition-test-tuple redefinition-test-generic ;" eval
 192
 193 [ t ] [
 194     [
 195         redefinition-test-generic ,
 196         "IN: temporary TUPLE: redefinition-test-tuple ;" eval
 197         redefinition-test-generic ,
 198     ] { } make all-equal?
 199 ] unit-test