extra/monads/monads-tests.factor

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