steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

monads: Rename words to not be class/word

db4
Doug Coleman 2013-03-24 01:38:25 -07:00
parent d4a0f94aa7
commit 37dea89f2d
2 changed files with 29 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
extra/monads/monads-tests.factor
View File

@ -6,11 +6,11 @@ IN: monads.tests
[ "OH HAI" identity-monad fail ] must-fail
[ 666 ] [
111 just [ 6 * ] fmap [ ] [ "OOPS" throw ] if-maybe
111 <just> [ 6 * ] fmap [ ] [ "OOPS" throw ] if-maybe
] unit-test
[ nothing ] [
111 just [ maybe-monad fail ] bind
111 <just> [ maybe-monad fail ] bind
] unit-test
[ 100 ] [
@ -70,10 +70,10 @@ IN: monads.tests
[ nothing ] [
{
[ "hi" just ]
[ " bye" append just ]
[ "hi" <just> ]
[ " bye" append <just> ]
[ drop nothing ]
[ reverse just ]
[ reverse <just> ]
} do
] unit-test
@ -121,9 +121,9 @@ LAZY: nats-from ( n -- list )
] unit-test
[ nothing ] [
5 just nothing maybe-monad apply
5 <just> nothing maybe-monad apply
] unit-test
[ T{ just f 15 } ] [
5 just [ 10 + ] just maybe-monad apply
5 <just> [ 10 + ] <just> maybe-monad apply
] unit-test

44
extra/monads/monads.factor
View File

@ -65,14 +65,14 @@ INSTANCE: maybe-monad monad
SINGLETON: nothing
TUPLE: just value ;
: just ( value -- just ) \ just boa ;
C: <just> just
UNION: maybe just nothing ;
INSTANCE: maybe monad
M: maybe monad-of drop maybe-monad ;
M: maybe-monad return drop just ;
M: maybe-monad return drop <just> ;
M: maybe-monad fail 2drop nothing ;
M: nothing >>= '[ drop _ ] ;
@ -86,18 +86,18 @@ SINGLETON: either-monad
INSTANCE: either-monad monad
TUPLE: left value ;
: left ( value -- left ) \ left boa ;
C: <left> left
TUPLE: right value ;
: right ( value -- right ) \ right boa ;
C: <right> right
UNION: either left right ;
INSTANCE: either monad
M: either monad-of drop either-monad ;
M: either-monad return drop right ;
M: either-monad fail drop left ;
M: either-monad return drop <right> ;
M: either-monad fail drop <left> ;
M: left >>= '[ drop _ ] ;
M: right >>= value>> '[ _ swap call( x -- y ) ] ;
@ -134,21 +134,21 @@ SINGLETON: state-monad
INSTANCE: state-monad monad
TUPLE: state quot ;
: state ( quot -- state ) \ state boa ;
C: <state> state
INSTANCE: state monad
M: state monad-of drop state-monad ;
M: state-monad return drop '[ _ 2array ] state ;
M: state-monad return drop '[ _ 2array ] <state> ;
M: state-monad fail "Fail" throw ;
: mcall ( x state -- y ) quot>> call( x -- y ) ;
M: state >>= '[ _ swap '[ _ mcall first2 @ mcall ] state ] ;
M: state >>= '[ _ swap '[ _ mcall first2 @ mcall ] <state> ] ;
: get-st ( -- state ) [ dup 2array ] state ;
: put-st ( value -- state ) '[ drop _ f 2array ] state ;
: get-st ( -- state ) [ dup 2array ] <state> ;
: put-st ( value -- state ) '[ drop _ f 2array ] <state> ;
: run-st ( state initial -- value ) swap mcall second ;
@ -159,37 +159,37 @@ SINGLETON: reader-monad
INSTANCE: reader-monad monad
TUPLE: reader quot ;
: reader ( quot -- reader ) \ reader boa ;
C: <reader> reader
INSTANCE: reader monad
M: reader monad-of drop reader-monad ;
M: reader-monad return drop '[ drop _ ] reader ;
M: reader-monad return drop '[ drop _ ] <reader> ;
M: reader-monad fail "Fail" throw ;
M: reader >>= '[ _ swap '[ dup _ mcall @ mcall ] reader ] ;
M: reader >>= '[ _ swap '[ dup _ mcall @ mcall ] <reader> ] ;
: run-reader ( reader env -- value ) swap quot>> call( env -- value ) ;
: ask ( -- reader ) [ ] reader ;
: local ( reader quot -- reader' ) swap '[ @ _ mcall ] reader ;
: ask ( -- reader ) [ ] <reader> ;
: local ( reader quot -- reader' ) swap '[ @ _ mcall ] <reader> ;
! Writer
SINGLETON: writer-monad
INSTANCE: writer-monad monad
TUPLE: writer value log ;
: writer ( value log -- writer ) \ writer boa ;
C: <writer> writer
M: writer monad-of drop writer-monad ;
M: writer-monad return drop { } writer ;
M: writer-monad return drop { } <writer> ;
M: writer-monad fail "Fail" throw ;
: run-writer ( writer -- value log ) [ value>> ] [ log>> ] bi ;
M: writer >>= '[ [ _ run-writer ] dip '[ @ run-writer ] dip append writer ] ;
M: writer >>= '[ [ _ run-writer ] dip '[ @ run-writer ] dip append <writer> ] ;
: pass ( writer -- writer' ) run-writer [ first2 ] dip swap call( x -- y ) writer ;
: listen ( writer -- writer' ) run-writer [ 2array ] keep writer ;
: tell ( seq -- writer ) f swap writer ;
: pass ( writer -- writer' ) run-writer [ first2 ] dip swap call( x -- y ) <writer> ;
: listen ( writer -- writer' ) run-writer [ 2array ] keep <writer> ;
: tell ( seq -- writer ) f swap <writer> ;