basis/functors/functors-tests.factor

   1 IN: functors.tests
   2 USING: functors tools.test math words kernel multiline parser
   3 io.streams.string generic ;
   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 GENERIC: some-generic ( a -- b )
  85
  86 ! Does replacing an ordinary word with a functor-generated one work?
  87 [ [ ] ] [
  88     <" IN: functors.tests
  89
  90     TUPLE: some-tuple ;
  91     : some-word ( -- ) ;
  92     M: some-tuple some-generic ;
  93     SYMBOL: some-symbol
  94     "> <string-reader> "functors-test" parse-stream
  95 ] unit-test
  96
  97 : test-redefinition ( -- )
  98     [ t ] [ "some-word" "functors.tests" lookup >boolean ] unit-test
  99     [ t ] [ "some-tuple" "functors.tests" lookup >boolean ] unit-test
 100     [ t ] [
 101         "some-tuple" "functors.tests" lookup
 102         "some-generic" "functors.tests" lookup method >boolean
 103     ] unit-test ;
 104     [ t ] [ "some-symbol" "functors.tests" lookup >boolean ] unit-test
 105
 106 test-redefinition
 107
 108 FUNCTOR: redefine-test ( W -- )
 109
 110 W-word DEFINES ${W}-word
 111 W-tuple DEFINES-CLASS ${W}-tuple
 112 W-generic IS ${W}-generic
 113 W-symbol DEFINES ${W}-symbol
 114
 115 WHERE
 116
 117 TUPLE: W-tuple ;
 118 : W-word ( -- ) ;
 119 M: W-tuple W-generic ;
 120 SYMBOL: W-symbol
 121
 122 ;FUNCTOR
 123
 124 [ [ ] ] [
 125     <" IN: functors.tests
 126     << "some" redefine-test >>
 127     "> <string-reader> "functors-test" parse-stream
 128 ] unit-test
 129
 130 test-redefinition
 131