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

44
extra/monads/monads.factor
View File

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