extra/roles/roles-tests.factor

   1 ! (c)2009 Joe Groff bsd license
   2 USING: accessors classes.tuple compiler.units kernel qw roles sequences
   3 tools.test ;
   4 IN: roles.tests
   5
   6 ROLE: fork tines ;
   7 ROLE: spoon bowl ;
   8 ROLE: instrument tone ;
   9 ROLE: tuning-fork <{ fork instrument } volume ;
  10
  11 ROLE-TUPLE: utensil handle ;
  12
  13 ! role consumption and tuple inheritance can be mixed
  14 ROLE-TUPLE: foon <{ utensil fork spoon } ;
  15 ROLE-TUPLE: tuning-spork <{ utensil spoon tuning-fork } ;
  16
  17 ! role class testing
  18 { t } [ fork role? ] unit-test
  19 { f } [ foon role? ] unit-test
  20
  21 ! roles aren't tuple classes by themselves and can't be instantiated
  22 { f } [ fork tuple-class? ] unit-test
  23 [ fork new ] must-fail
  24
  25 ! tuples which consume roles fall under their class
  26 { t } [ foon new fork? ] unit-test
  27 { t } [ foon new spoon? ] unit-test
  28 { f } [ foon new tuning-fork? ] unit-test
  29 { f } [ foon new instrument? ] unit-test
  30
  31 { t } [ tuning-spork new fork? ] unit-test
  32 { t } [ tuning-spork new spoon? ] unit-test
  33 { t } [ tuning-spork new tuning-fork? ] unit-test
  34 { t } [ tuning-spork new instrument? ] unit-test
  35
  36 ! consumed role slots are placed in tuples in order
  37 { qw{ handle tines bowl } } [ foon all-slots [ name>> ] map ] unit-test
  38 { qw{ handle bowl tines tone volume } } [ tuning-spork all-slots [ name>> ] map ] unit-test
  39
  40 ! can't combine roles whose slots overlap
  41 ROLE: bong bowl ;
  42 SYMBOL: spong
  43
  44 [ [ spong { spoon bong } { } define-tuple-class-with-roles ] with-compilation-unit ]
  45 [ role-slot-overlap? ] must-fail-with
  46
  47 [ [ spong { spoon bong } { } define-role ] with-compilation-unit ]
  48 [ role-slot-overlap? ] must-fail-with
  49
  50 ! can't try to inherit multiple tuple classes
  51 ROLE-TUPLE: tool blade ;
  52 SYMBOL: knife
  53
  54 [ knife { utensil tool } { } define-tuple-class-with-roles ]
  55 [ multiple-inheritance-attempted? ] must-fail-with
  56
  57 ! make sure method dispatch works
  58 GENERIC: poke ( pokee poker -- result )
  59 GENERIC: scoop ( scoopee scooper -- result )
  60 GENERIC: tune ( tunee tuner -- result )
  61
  62 M: fork poke drop " got poked" append ;
  63 M: spoon scoop drop " got scooped" append ;
  64 M: instrument tune drop " got tuned" append ;
  65
  66 { "potato got poked" "potato got scooped" "potato got tuned" }
  67 [ "potato" tuning-spork new [ poke ] [ scoop ] [ tune ] 2tri ] unit-test