extra/roles/roles-tests.factor

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