extra/monads/monads-tests.factor

   1 USING: tools.test monads math kernel sequences lists promises ;
   2 IN: monads.tests
   3
   4 [ 5 ] [ 1 identity-monad return [ 4 + ] fmap run-identity ] unit-test
   5 [ "OH HAI" identity-monad fail ] must-fail
   6
   7 [ 666 ] [
   8     111 just [ 6 * ] fmap [ ] [ "OOPS" throw ] if-maybe
   9 ] unit-test
  10
  11 [ nothing ] [
  12     111 just [ maybe-monad fail ] bind
  13 ] unit-test
  14
  15 [ 100 ] [
  16     5 either-monad return [ 10 * ] [ 20 * ] if-either
  17 ] unit-test
  18
  19 [ T{ left f "OOPS" } ] [
  20     5 either-monad return >>= [ drop "OOPS" either-monad fail ] swap call
  21 ] unit-test
  22
  23 [ { 10 20 30 } ] [
  24     { 1 2 3 } [ 10 * ] fmap
  25 ] unit-test
  26
  27 [ { } ] [
  28     { 1 2 3 } [ drop "OOPS" array-monad fail ] bind
  29 ] unit-test
  30
  31 [ 5 ] [
  32     5 state-monad return "initial state" run-st
  33 ] unit-test
  34
  35 [ 8 ] [
  36     5 state-monad return [ 3 + state-monad return ] bind
  37     "initial state" run-st
  38 ] unit-test
  39
  40 [ 8 ] [
  41     5 state-monad return >>=
  42     [ 3 + state-monad return ] swap call
  43     "initial state" run-st
  44 ] unit-test
  45
  46 [ 11 ] [
  47     f state-monad return >>=
  48     [ drop get-st ] swap call
  49     11 run-st
  50 ] unit-test
  51
  52 [ 15 ] [
  53     f state-monad return
  54     [ drop get-st ] bind
  55     [ 4 + put-st ] bind
  56     [ drop get-st ] bind
  57     11 run-st
  58 ] unit-test
  59
  60 [ 15 ] [
  61     {
  62         [ f return-st ]
  63         [ drop get-st ]
  64         [ 4 + put-st ]
  65         [ drop get-st ]
  66     } do
  67     11 run-st
  68 ] unit-test
  69
  70 [ nothing ] [
  71     {
  72         [ "hi" just ]
  73         [ " bye" append just ]
  74         [ drop nothing ]
  75         [ reverse just ]
  76     } do
  77 ] unit-test
  78
  79 LAZY: nats-from ( n -- list )
  80     dup 1+ nats-from cons ;
  81
  82 : nats 0 nats-from ;
  83
  84 [ 3 ] [
  85     {
  86         [ nats ]
  87         [ dup 3 = [ list-monad return ] [ list-monad fail ] if ]
  88     } do car
  89 ] unit-test
  90
  91 [ 9/11 ] [
  92     {
  93         [ ask ]
  94     } do 9/11 run-reader
  95 ] unit-test
  96
  97 [ 8 ] [
  98     {
  99         [ ask ]
 100         [ 3 + reader-monad return ]
 101     } do
 102     5 run-reader
 103 ] unit-test
 104
 105 [ 6 ] [
 106     f reader-monad return [ drop ask ] bind [ 1 + ] local 5 run-reader
 107 ] unit-test
 108
 109 [ f { 1 2 3 } ] [
 110     5 writer-monad return
 111     [ drop { 1 2 3 } tell ] bind
 112     run-writer
 113 ] unit-test
 114
 115 [ T{ identity f 7 } ]
 116 [
 117     4 identity-monad return
 118     [ 3 + ] identity-monad return
 119     identity-monad apply
 120 ] unit-test
 121
 122 [ nothing ] [
 123     5 just nothing maybe-monad apply
 124 ] unit-test
 125
 126 [ T{ just f 15 } ] [
 127     5 just [ 10 + ] just maybe-monad apply
 128 ] unit-test