Merge branch 'master' of git://factorcode.org/git/factor

[factor.git] / extra / monads / monads.factor

diff --git a/extra/monads/monads.factor b/extra/monads/monads.factor
index c1ab4400ba65b52e932d8a6e8e91494fcf541be4..f4503cbdd3f1f1f552f91f3a96002d95332de64f 100644 (file)
--- a/extra/monads/monads.factor
+++ b/extra/monads/monads.factor
@@ -6,7 +6,7 @@ shuffle ;
 IN: monads
 
 ! Functors
-GENERIC# fmap 1 ( functor quot -- functor' ) inline
+GENERIC# fmap 1 ( functor quot -- functor' )
 
 ! Monads
 
@@ -14,15 +14,16 @@ GENERIC# fmap 1 ( functor quot -- functor' ) inline
 MIXIN: monad
 
 GENERIC: monad-of ( mvalue -- singleton )
-GENERIC: return ( string singleton -- mvalue )
+GENERIC: return ( value singleton -- mvalue )
 GENERIC: fail ( value singleton -- mvalue )
 GENERIC: >>= ( mvalue -- quot )
 
 M: monad return monad-of return ;
 M: monad fail   monad-of fail   ;
 
-: bind ( mvalue quot -- mvalue' ) swap >>= call ;
-: >>   ( mvalue k -- mvalue' ) '[ drop , ] bind ;
+: bind ( mvalue quot -- mvalue' ) swap >>= call( quot -- mvalue ) ;
+: bind* ( mvalue quot -- mvalue' ) '[ drop @ ] bind ;
+: >>   ( mvalue k -- mvalue' ) '[ drop _ ] bind ;
 
 :: lift-m2 ( m1 m2 f monad -- m3 )
     m1 [| x1 | m2 [| x2 | x1 x2 f monad return ] bind ] bind ;
@@ -30,14 +31,14 @@ M: monad fail   monad-of fail   ;
 :: apply ( mvalue mquot monad -- result )
     mvalue [| value |
         mquot [| quot |
-            value quot call monad return
+            value quot call( value -- mvalue ) monad return
         ] bind
     ] bind ;
 
-M: monad fmap over '[ @ , return ] bind ;
+M: monad fmap over '[ @ _ return ] bind ;
 
 ! 'do' notation
-: do ( quots -- result ) unclip dip [ bind ] each ;
+: do ( quots -- result ) unclip [ call( -- mvalue ) ] curry dip [ bind ] each ;
 
 ! Identity
 SINGLETON: identity-monad
@@ -51,7 +52,7 @@ M: identity monad-of drop identity-monad ;
 M: identity-monad return drop identity boa ;
 M: identity-monad fail   "Fail" throw ;
 
-M: identity >>= value>> '[ , _ call ] ;
+M: identity >>= value>> '[ _ swap call( x -- y ) ] ;
 
 : run-identity ( identity -- value ) value>> ;
 
@@ -62,7 +63,7 @@ INSTANCE:  maybe-monad monad
 SINGLETON: nothing
 
 TUPLE: just value ;
-: just \ just boa ;
+: just ( value -- just ) \ just boa ;
 
 UNION: maybe just nothing ;
 INSTANCE: maybe monad
@@ -72,8 +73,8 @@ M: maybe monad-of drop maybe-monad ;
 M: maybe-monad return drop just ;
 M: maybe-monad fail   2drop nothing ;
 
-M: nothing >>= '[ drop , ] ;
-M: just    >>= value>> '[ , _ call ] ;
+M: nothing >>= '[ drop _ ] ;
+M: just    >>= value>> '[ _ swap call( x -- y ) ] ;
 
 : if-maybe ( maybe just-quot nothing-quot -- )
     pick nothing? [ 2nip call ] [ drop [ value>> ] dip call ] if ; inline
@@ -83,10 +84,10 @@ SINGLETON: either-monad
 INSTANCE:  either-monad monad
 
 TUPLE: left value ;
-: left \ left boa ;
+: left ( value -- left ) \ left boa ;
 
 TUPLE: right value ;
-: right \ right boa ;
+: right ( value -- right ) \ right boa ;
 
 UNION: either left right ;
 INSTANCE: either monad
@@ -96,8 +97,8 @@ M: either monad-of drop either-monad ;
 M: either-monad return  drop right ;
 M: either-monad fail    drop left ;
 
-M: left  >>= '[ drop , ] ;
-M: right >>= value>> '[ , _ call ] ;
+M: left  >>= '[ drop _ ] ;
+M: right >>= value>> '[ _ swap call( x -- y ) ] ;
 
 : if-either ( value left-quot right-quot -- )
     [ [ value>> ] [ left? ] bi ] 2dip if ; inline
@@ -112,7 +113,7 @@ M: array-monad fail   2drop { } ;
 
 M: array monad-of drop array-monad ;
 
-M: array >>= '[ , _ map concat ] ;
+M: array >>= '[ _ swap map concat ] ;
 
 ! List
 SINGLETON: list-monad
@@ -124,59 +125,59 @@ M: list-monad fail   2drop nil ;
 
 M: list monad-of drop list-monad ;
 
-M: list >>= '[ , _ lazy-map lconcat ] ;
+M: list >>= '[ _ swap lazy-map lconcat ] ;
 
 ! State
 SINGLETON: state-monad
 INSTANCE:  state-monad monad
 
 TUPLE: state quot ;
-: state \ state boa ;
+: state ( quot -- state ) \ state boa ;
 
 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 quot>> call ;
+: mcall ( x state -- y ) quot>> call( x -- y ) ;
 
-M: state >>= '[ , _ '[ , 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 ;
+: put-st ( value -- state ) '[ drop _ f 2array ] state ;
 
-: run-st ( state initial -- ) swap mcall second ;
+: run-st ( state initial -- value ) swap mcall second ;
 
-: return-st state-monad return ;
+: return-st ( value -- mvalue ) state-monad return ;
 
 ! Reader
 SINGLETON: reader-monad
 INSTANCE:  reader-monad monad
 
 TUPLE: reader quot ;
-: reader \ reader boa ;
+: reader ( quot -- reader ) \ reader boa ;
 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 >>= '[ , _ '[ dup , mcall @ mcall ] reader ] ;
+M: reader >>= '[ _ swap '[ dup _ mcall @ mcall ] reader ] ;
 
-: run-reader ( reader env -- ) swap mcall ;
+: run-reader ( reader env -- value ) swap quot>> call( env -- value ) ;
 
 : ask ( -- reader ) [ ] reader ;
-: local ( reader quot -- reader' ) swap '[ @ , mcall ] reader ;
+: local ( reader quot -- reader' ) swap '[ @ _ mcall ] reader ;
 
 ! Writer
 SINGLETON: writer-monad
 INSTANCE:  writer-monad monad
 
 TUPLE: writer value log ;
-: writer \ writer boa ;
+: writer ( value log -- writer ) \ writer boa ;
 
 M: writer monad-of drop writer-monad ;
 
@@ -185,8 +186,8 @@ M: writer-monad fail   "Fail" throw ;
 
 : run-writer ( writer -- value log ) [ value>> ] [ log>> ] bi ;
 
-M: writer >>= '[ , run-writer _ '[ @ run-writer ] dip append writer ] ;
+M: writer >>= '[ [ _ run-writer ] dip '[ @ run-writer ] dip append writer ] ;
 
-: pass ( writer -- writer' ) run-writer [ first2 ] dip swap call 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 ;