extra/delegate/delegate-tests.factor

   1 USING: delegate kernel arrays tools.test words math definitions
   2 compiler.units parser generic prettyprint io.streams.string ;
   3 IN: delegate.tests
   4
   5 TUPLE: hello this that ;
   6 C: <hello> hello
   7
   8 TUPLE: goodbye these those ;
   9 C: <goodbye> goodbye
  10
  11 GENERIC: foo ( x -- y )
  12 GENERIC: bar ( a -- b )
  13 GENERIC# whoa 1 ( s t -- w )
  14 PROTOCOL: baz foo { bar 0 } { whoa 1 } ;
  15
  16 : hello-test ( hello/goodbye -- array )
  17     [ hello? ] [ hello-this ] [ hello-that ] tri 3array ;
  18
  19 CONSULT: baz goodbye goodbye-these ;
  20 M: hello foo hello-this ;
  21 M: hello bar hello-test ;
  22 M: hello whoa >r hello-this r> + ;
  23
  24 GENERIC: bing ( c -- d )
  25 PROTOCOL: bee bing ;
  26 CONSULT: hello goodbye goodbye-those ;
  27 M: hello bing hello-test ;
  28
  29 [ 1 { t 1 0 } ] [ 1 0 <hello> [ foo ] [ bar ] bi ] unit-test
  30 [ { t 1 0 } ] [ 1 0 <hello> bing ] unit-test
  31 [ 1 ] [ 1 0 <hello> f <goodbye> foo ] unit-test
  32 [ { t 1 0 } ] [ 1 0 <hello> f <goodbye> bar ] unit-test
  33 [ 3 ] [ 1 0 <hello> 2 whoa ] unit-test
  34 [ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test
  35
  36 [ ] [ 10 [ "USE: delegate IN: delegate.tests CONSULT: baz goodbye goodbye-these ;" eval ] times ] unit-test
  37 [ H{ { goodbye [ goodbye-these ] } } ] [ baz protocol-consult ] unit-test
  38 [ H{ } ] [ bee protocol-consult ] unit-test
  39
  40 [ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ;\n" ] [ [ baz see ] with-string-writer ] unit-test
  41
  42 ! [ ] [ [ baz forget ] with-compilation-unit ] unit-test
  43 ! [ f ] [ goodbye baz method ] unit-test