130 lines
2.3 KiB
Factor
130 lines
2.3 KiB
Factor
USING: tools.test math kernel sequences lists promises monads ;
|
|
FROM: monads => do ;
|
|
IN: monads.tests
|
|
|
|
[ 5 ] [ 1 identity-monad return [ 4 + ] fmap run-identity ] unit-test
|
|
[ "OH HAI" identity-monad fail ] must-fail
|
|
|
|
[ 666 ] [
|
|
111 <just> [ 6 * ] fmap [ ] [ "OOPS" throw ] if-maybe
|
|
] unit-test
|
|
|
|
[ nothing ] [
|
|
111 <just> [ maybe-monad fail ] bind
|
|
] unit-test
|
|
|
|
[ 100 ] [
|
|
5 either-monad return [ 10 * ] [ 20 * ] if-either
|
|
] unit-test
|
|
|
|
[ T{ left f "OOPS" } ] [
|
|
5 either-monad return >>= [ drop "OOPS" either-monad fail ] swap call
|
|
] unit-test
|
|
|
|
[ { 10 20 30 } ] [
|
|
{ 1 2 3 } [ 10 * ] fmap
|
|
] unit-test
|
|
|
|
[ { } ] [
|
|
{ 1 2 3 } [ drop "OOPS" array-monad fail ] bind
|
|
] unit-test
|
|
|
|
[ 5 ] [
|
|
5 state-monad return "initial state" run-st
|
|
] unit-test
|
|
|
|
[ 8 ] [
|
|
5 state-monad return [ 3 + state-monad return ] bind
|
|
"initial state" run-st
|
|
] unit-test
|
|
|
|
[ 8 ] [
|
|
5 state-monad return >>=
|
|
[ 3 + state-monad return ] swap call
|
|
"initial state" run-st
|
|
] unit-test
|
|
|
|
[ 11 ] [
|
|
f state-monad return >>=
|
|
[ drop get-st ] swap call
|
|
11 run-st
|
|
] unit-test
|
|
|
|
[ 15 ] [
|
|
f state-monad return
|
|
[ drop get-st ] bind
|
|
[ 4 + put-st ] bind
|
|
[ drop get-st ] bind
|
|
11 run-st
|
|
] unit-test
|
|
|
|
[ 15 ] [
|
|
{
|
|
[ f return-st ]
|
|
[ drop get-st ]
|
|
[ 4 + put-st ]
|
|
[ drop get-st ]
|
|
} do
|
|
11 run-st
|
|
] unit-test
|
|
|
|
[ nothing ] [
|
|
{
|
|
[ "hi" <just> ]
|
|
[ " bye" append <just> ]
|
|
[ drop nothing ]
|
|
[ reverse <just> ]
|
|
} do
|
|
] unit-test
|
|
|
|
LAZY: nats-from ( n -- list )
|
|
dup 1 + nats-from cons ;
|
|
|
|
: nats ( -- list ) 0 nats-from ;
|
|
|
|
[ 3 ] [
|
|
{
|
|
[ nats ]
|
|
[ dup 3 = [ list-monad return ] [ list-monad fail ] if ]
|
|
} do car
|
|
] unit-test
|
|
|
|
[ 9/11 ] [
|
|
{
|
|
[ ask ]
|
|
} do 9/11 run-reader
|
|
] unit-test
|
|
|
|
[ 8 ] [
|
|
{
|
|
[ ask ]
|
|
[ 3 + reader-monad return ]
|
|
} do
|
|
5 run-reader
|
|
] unit-test
|
|
|
|
[ 6 ] [
|
|
f reader-monad return [ drop ask ] bind [ 1 + ] local 5 run-reader
|
|
] unit-test
|
|
|
|
[ f { 1 2 3 } ] [
|
|
5 writer-monad return
|
|
[ drop { 1 2 3 } tell ] bind
|
|
run-writer
|
|
] unit-test
|
|
|
|
[ T{ identity f 7 } ]
|
|
[
|
|
4 identity-monad return
|
|
[ 3 + ] identity-monad return
|
|
identity-monad apply
|
|
] unit-test
|
|
|
|
[ nothing ] [
|
|
5 <just> nothing maybe-monad apply
|
|
] unit-test
|
|
|
|
[ T{ just f 15 } ] [
|
|
5 <just> [ 10 + ] <just> maybe-monad apply
|
|
] unit-test
|