core/classes/maybe/maybe-tests.factor

   1 ! Copyright (C) 2011 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: classes.maybe eval generic.single kernel tools.test
   4 math classes accessors slots classes.algebra
   5 classes.algebra.private ;
   6 IN: classes.maybe.tests
   7
   8 [ t ] [ 3 maybe{ integer } instance? ] unit-test
   9 [ t ] [ f maybe{ integer } instance? ] unit-test
  10 [ f ] [ 3.0 maybe{ integer } instance? ] unit-test
  11
  12 TUPLE: maybe-integer-container { something maybe{ integer } } ;
  13
  14 [ f ] [ maybe-integer-container new something>> ] unit-test
  15 [ 3 ] [ maybe-integer-container new 3 >>something something>> ] unit-test
  16 [ maybe-integer-container new 3.0 >>something ] [ bad-slot-value? ] must-fail-with
  17
  18 TUPLE: self-pointer { next maybe{ self-pointer } } ;
  19
  20 [ T{ self-pointer { next T{ self-pointer } } } ]
  21 [ self-pointer new self-pointer new >>next ] unit-test
  22
  23 [ t ] [ f maybe{ POSTPONE: f } instance? ] unit-test
  24
  25 PREDICATE: natural < maybe{ integer }
  26     0 > ;
  27
  28 [ f ] [ -1 natural? ] unit-test
  29 [ f ] [ 0 natural? ] unit-test
  30 [ t ] [ 1 natural? ] unit-test
  31
  32 [ t ] [ f maybe{ maybe{ integer } } instance? ] unit-test
  33 [ t ] [ 3 maybe{ maybe{ integer } } instance? ] unit-test
  34 [ f ] [ 3.03 maybe{ maybe{ integer } } instance? ] unit-test
  35
  36 INTERSECTION: only-f maybe{ integer } POSTPONE: f ;
  37
  38 [ t ] [ f only-f instance? ] unit-test
  39 [ f ] [ t only-f instance? ] unit-test
  40 [ f ] [ 30 only-f instance? ] unit-test
  41
  42 UNION: ?integer-float maybe{ integer } maybe{ float } ;
  43
  44 [ t ] [ 30 ?integer-float instance? ] unit-test
  45 [ t ] [ 30.0 ?integer-float instance? ] unit-test
  46 [ t ] [ f ?integer-float instance? ] unit-test
  47 [ f ] [ t ?integer-float instance? ] unit-test
  48
  49 TUPLE: foo ;
  50 GENERIC: lol ( obj -- string )
  51 M: maybe{ foo } lol drop "lol" ;
  52
  53 [ "lol" ] [ foo new lol ] unit-test
  54 [ "lol" ] [ f lol ] unit-test
  55 [ 3 lol ] [ no-method? ] must-fail-with
  56
  57 TUPLE: foo2 a ;
  58 GENERIC: lol2 ( obj -- string )
  59 M: maybe{ foo } lol2 drop "lol2" ;
  60 M: f lol2 drop "lol22" ;
  61
  62 [ "lol2" ] [ foo new lol2 ] unit-test
  63 [ "lol22" ] [ f lol2 ] unit-test
  64 [ 3 lol2 ] [ no-method? ] must-fail-with
  65
  66 [ t ] [ \ + <maybe> classoid? ] unit-test
  67 [ f ] [ \ + <maybe> valid-classoid? ] unit-test
  68
  69 [ "IN: classes-tests maybe{ 1 2 3 }" eval( -- ) ]
  70 [ error>> not-classoids? ] must-fail-with