extra/monads/monads-tests.factor

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