unmaintained/multi-methods/tests/syntax.factor

   1 USING: multi-methods tools.test math sequences namespaces system
   2 kernel strings definitions prettyprint debugger arrays
   3 hashtables continuations classes assocs accessors see ;
   4 RENAME: GENERIC: multi-methods => multi-methods:GENERIC:
   5 IN: multi-methods.tests
   6
   7 multi-methods:GENERIC: first-test ( -- )
   8
   9 [ t ] [ \ first-test generic? ] unit-test
  10
  11 MIXIN: thing
  12
  13 SINGLETON: paper    INSTANCE: paper thing
  14 SINGLETON: scissors INSTANCE: scissors thing
  15 SINGLETON: rock     INSTANCE: rock thing
  16
  17 multi-methods:GENERIC: beats? ( obj1 obj2 -- ? )
  18
  19 METHOD: beats? { paper scissors } 2drop t ;
  20 METHOD: beats? { scissors rock } 2drop t ;
  21 METHOD: beats? { rock paper } 2drop t ;
  22 METHOD: beats? { thing thing } 2drop f ;
  23
  24 : play ( obj1 obj2 -- ? ) beats? ;
  25
  26 [ { } 3 play ] must-fail
  27 [ t ] [ error get no-method? ] unit-test
  28 [ ] [ error get error. ] unit-test
  29 [ { { } 3 } ] [ error get arguments>> ] unit-test
  30 [ t ] [ paper scissors play ] unit-test
  31 [ f ] [ scissors paper play ] unit-test
  32
  33 [ t ] [ { beats? paper scissors } method-spec? ] unit-test
  34 [ ] [ { beats? paper scissors } see ] unit-test
  35
  36 SYMBOL: some-var
  37
  38 multi-methods:GENERIC: hook-test ( obj -- obj )
  39
  40 METHOD: hook-test { array { some-var array } } reverse ;
  41 METHOD: hook-test { { some-var array } } class-of ;
  42 METHOD: hook-test { hashtable { some-var number } } assoc-size ;
  43
  44 { 1 2 3 } some-var set
  45 [ { f t t } ] [ { t t f } hook-test ] unit-test
  46 [ fixnum ] [ 3 hook-test ] unit-test
  47 5.0 some-var set
  48 [ 0 ] [ H{ } hook-test ] unit-test
  49
  50 "error" some-var set
  51 [ H{ } hook-test ] must-fail
  52 [ t ] [ error get no-method? ] unit-test
  53 [ { H{ } "error" } ] [ error get arguments>> ] unit-test
  54
  55 MIXIN: busted
  56
  57 TUPLE: busted-1 ;
  58 TUPLE: busted-2 ; INSTANCE: busted-2 busted
  59 TUPLE: busted-3 ;
  60
  61 multi-methods:GENERIC: busted-sort ( obj1 obj2 -- obj1 obj2 )
  62
  63 METHOD: busted-sort { busted-1 busted-2 } ;
  64 METHOD: busted-sort { busted-2 busted-3 } ;
  65 METHOD: busted-sort { busted busted } ;