From 37dea89f2d3144edd426d93e37455e8dbdd7178d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 24 Mar 2013 01:38:25 -0700 Subject: [PATCH] monads: Rename words to not be class/word --- extra/monads/monads-tests.factor | 14 +++++----- extra/monads/monads.factor | 44 ++++++++++++++++---------------- 2 files changed, 29 insertions(+), 29 deletions(-) diff --git a/extra/monads/monads-tests.factor b/extra/monads/monads-tests.factor index 5504633bb6..4c568f5f5f 100644 --- a/extra/monads/monads-tests.factor +++ b/extra/monads/monads-tests.factor @@ -6,11 +6,11 @@ IN: monads.tests [ "OH HAI" identity-monad fail ] must-fail [ 666 ] [ - 111 just [ 6 * ] fmap [ ] [ "OOPS" throw ] if-maybe + 111 [ 6 * ] fmap [ ] [ "OOPS" throw ] if-maybe ] unit-test [ nothing ] [ - 111 just [ maybe-monad fail ] bind + 111 [ maybe-monad fail ] bind ] unit-test [ 100 ] [ @@ -70,10 +70,10 @@ IN: monads.tests [ nothing ] [ { - [ "hi" just ] - [ " bye" append just ] + [ "hi" ] + [ " bye" append ] [ drop nothing ] - [ reverse just ] + [ reverse ] } do ] unit-test @@ -121,9 +121,9 @@ LAZY: nats-from ( n -- list ) ] unit-test [ nothing ] [ - 5 just nothing maybe-monad apply + 5 nothing maybe-monad apply ] unit-test [ T{ just f 15 } ] [ - 5 just [ 10 + ] just maybe-monad apply + 5 [ 10 + ] maybe-monad apply ] unit-test diff --git a/extra/monads/monads.factor b/extra/monads/monads.factor index a859c36f2e..73e2b98eb2 100644 --- a/extra/monads/monads.factor +++ b/extra/monads/monads.factor @@ -65,14 +65,14 @@ INSTANCE: maybe-monad monad SINGLETON: nothing TUPLE: just value ; -: just ( value -- just ) \ just boa ; +C: 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 ; 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 TUPLE: right value ; -: right ( value -- right ) \ right boa ; +C: 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 ; +M: either-monad fail drop ; 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 INSTANCE: state monad M: state monad-of drop state-monad ; -M: state-monad return drop '[ _ 2array ] state ; +M: state-monad return drop '[ _ 2array ] ; 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 ] ] ; -: get-st ( -- state ) [ dup 2array ] state ; -: put-st ( value -- state ) '[ drop _ f 2array ] state ; +: get-st ( -- state ) [ dup 2array ] ; +: put-st ( value -- state ) '[ drop _ f 2array ] ; : 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 INSTANCE: reader monad M: reader monad-of drop reader-monad ; -M: reader-monad return drop '[ drop _ ] reader ; +M: reader-monad return drop '[ drop _ ] ; M: reader-monad fail "Fail" throw ; -M: reader >>= '[ _ swap '[ dup _ mcall @ mcall ] reader ] ; +M: reader >>= '[ _ swap '[ dup _ mcall @ mcall ] ] ; : run-reader ( reader env -- value ) swap quot>> call( env -- value ) ; -: ask ( -- reader ) [ ] reader ; -: local ( reader quot -- reader' ) swap '[ @ _ mcall ] reader ; +: ask ( -- reader ) [ ] ; +: local ( reader quot -- reader' ) swap '[ @ _ mcall ] ; ! Writer SINGLETON: writer-monad INSTANCE: writer-monad monad TUPLE: writer value log ; -: writer ( value log -- writer ) \ writer boa ; +C: writer M: writer monad-of drop writer-monad ; -M: writer-monad return drop { } writer ; +M: writer-monad return drop { } ; 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 ] ; -: 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 ) ; +: listen ( writer -- writer' ) run-writer [ 2array ] keep ; +: tell ( seq -- writer ) f swap ; -- 2.34.1