basis/functors/functors-tests.factor

   1 USING: functors tools.test math words kernel multiline parser
   2 io.streams.string generic ;
   3 IN: functors.tests
   4
   5 <<
   6
   7 FUNCTOR: define-box ( T -- )
   8
   9 B DEFINES-CLASS ${T}-box
  10 <B> DEFINES <${B}>
  11
  12 WHERE
  13
  14 TUPLE: B { value T } ;
  15
  16 C: <B> B ( T -- B )
  17
  18 ;FUNCTOR
  19
  20 \ float define-box
  21
  22 >>
  23
  24 { 1 0 } [ define-box ] must-infer-as
  25
  26 [ T{ float-box f 5.0 } ] [ 5.0 <float-box> ] unit-test
  27
  28 : twice ( word -- )
  29     [ execute ] [ execute ] bi ; inline
  30 <<
  31
  32 FUNCTOR: wrapper-test ( W -- )
  33
  34 WW DEFINES ${W}${W}
  35
  36 WHERE
  37
  38 : WW ( a -- b ) \ W twice ; inline
  39
  40 ;FUNCTOR
  41
  42 \ sq wrapper-test
  43
  44 >>
  45
  46 [ 16 ] [ 2 sqsq ] unit-test
  47
  48 <<
  49
  50 FUNCTOR: wrapper-test-2 ( W -- )
  51
  52 W DEFINES ${W}
  53
  54 WHERE
  55
  56 : W ( a b -- c ) \ + execute ;
  57
  58 ;FUNCTOR
  59
  60 "blah" wrapper-test-2
  61
  62 >>
  63
  64 [ 4 ] [ 1 3 blah ] unit-test
  65
  66 <<
  67
  68 FUNCTOR: symbol-test ( W -- )
  69
  70 W DEFINES ${W}
  71
  72 WHERE
  73
  74 SYMBOL: W
  75
  76 ;FUNCTOR
  77
  78 "blorgh" symbol-test
  79
  80 >>
  81
  82 [ blorgh ] [ blorgh ] unit-test
  83
  84 <<
  85
  86 FUNCTOR: generic-test ( W -- )
  87
  88 W DEFINES ${W}
  89
  90 WHERE
  91
  92 GENERIC: W ( a -- b )
  93 M: object W ;
  94 M: integer W 1 + ;
  95
  96 ;FUNCTOR
  97
  98 "snurv" generic-test
  99
 100 >>
 101
 102 [ 2   ] [ 1   snurv ] unit-test
 103 [ 3.0 ] [ 3.0 snurv ] unit-test
 104
 105 ! Does replacing an ordinary word with a functor-generated one work?
 106 [ [ ] ] [
 107     <" IN: functors.tests
 108
 109     TUPLE: some-tuple ;
 110     : some-word ( -- ) ;
 111     GENERIC: some-generic ( a -- b )
 112     M: some-tuple some-generic ;
 113     SYMBOL: some-symbol
 114     "> <string-reader> "functors-test" parse-stream
 115 ] unit-test
 116
 117 : test-redefinition ( -- )
 118     [ t ] [ "some-word" "functors.tests" lookup >boolean ] unit-test
 119     [ t ] [ "some-tuple" "functors.tests" lookup >boolean ] unit-test
 120     [ t ] [ "some-generic" "functors.tests" lookup >boolean ] unit-test
 121     [ t ] [
 122         "some-tuple" "functors.tests" lookup
 123         "some-generic" "functors.tests" lookup method >boolean
 124     ] unit-test ;
 125     [ t ] [ "some-symbol" "functors.tests" lookup >boolean ] unit-test
 126
 127 test-redefinition
 128
 129 FUNCTOR: redefine-test ( W -- )
 130
 131 W-word DEFINES ${W}-word
 132 W-tuple DEFINES-CLASS ${W}-tuple
 133 W-generic DEFINES ${W}-generic
 134 W-symbol DEFINES ${W}-symbol
 135
 136 WHERE
 137
 138 TUPLE: W-tuple ;
 139 : W-word ( -- ) ;
 140 GENERIC: W-generic ( a -- b )
 141 M: W-tuple W-generic ;
 142 SYMBOL: W-symbol
 143
 144 ;FUNCTOR
 145
 146 [ [ ] ] [
 147     <" IN: functors.tests
 148     << "some" redefine-test >>
 149     "> <string-reader> "functors-test" parse-stream
 150 ] unit-test
 151
 152 test-redefinition
 153