Move make to its own vocabulary, remove fry _ feature

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

diff --git a/extra/monads/monads.factor b/extra/monads/monads.factor
index e110cb38d3397690b146bffe1cbc98412998df18..bff720b2a36b506bcb5bc5d15f1bacbcb53cbf2e 100644 (file)
--- a/extra/monads/monads.factor
+++ b/extra/monads/monads.factor
@@ -51,7 +51,7 @@ M: identity monad-of drop identity-monad ;
 M: identity-monad return drop identity boa ;
 M: identity-monad fail   "Fail" throw ;
 
 M: identity-monad return drop identity boa ;
 M: identity-monad fail   "Fail" throw ;
 

-M: identity >>= value>> '[ , _ call ] ;
+M: identity >>= value>> '[ , swap call ] ;

 
 : run-identity ( identity -- value ) value>> ;
 
 
 : run-identity ( identity -- value ) value>> ;
 


@@ -73,7 +73,7 @@ M: maybe-monad return drop just ;
 M: maybe-monad fail   2drop nothing ;
 
 M: nothing >>= '[ drop , ] ;
 M: maybe-monad fail   2drop nothing ;
 
 M: nothing >>= '[ drop , ] ;

-M: just    >>= value>> '[ , _ call ] ;
+M: just    >>= value>> '[ , swap call ] ;

 
 : if-maybe ( maybe just-quot nothing-quot -- )
     pick nothing? [ 2nip call ] [ drop [ value>> ] dip call ] if ; inline
 
 : if-maybe ( maybe just-quot nothing-quot -- )
     pick nothing? [ 2nip call ] [ drop [ value>> ] dip call ] if ; inline


@@ -97,7 +97,7 @@ M: either-monad return  drop right ;
 M: either-monad fail    drop left ;
 
 M: left  >>= '[ drop , ] ;
 M: either-monad fail    drop left ;
 
 M: left  >>= '[ drop , ] ;

-M: right >>= value>> '[ , _ call ] ;
+M: right >>= value>> '[ , swap call ] ;

 
 : if-either ( value left-quot right-quot -- )
     [ [ value>> ] [ left? ] bi ] 2dip if ; inline
 
 : if-either ( value left-quot right-quot -- )
     [ [ value>> ] [ left? ] bi ] 2dip if ; inline


@@ -112,7 +112,7 @@ M: array-monad fail   2drop { } ;
 
 M: array monad-of drop array-monad ;
 
 
 M: array monad-of drop array-monad ;
 

-M: array >>= '[ , _ map concat ] ;
+M: array >>= '[ , swap map concat ] ;

 
 ! List
 SINGLETON: list-monad
 
 ! List
 SINGLETON: list-monad


@@ -124,7 +124,7 @@ M: list-monad fail   2drop nil ;
 
 M: list monad-of drop list-monad ;
 
 
 M: list monad-of drop list-monad ;
 

-M: list >>= '[ , _ lazy-map lconcat ] ;
+M: list >>= '[ , swap lazy-map lconcat ] ;

 
 ! State
 SINGLETON: state-monad
 
 ! State
 SINGLETON: state-monad


@@ -142,7 +142,7 @@ M: state-monad fail   "Fail" throw ;
 
 : mcall ( state -- ) quot>> call ;
 
 
 : mcall ( state -- ) quot>> call ;
 

-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 ;
 
 : get-st ( -- state ) [ dup 2array ] state ;
 : put-st ( value -- state ) '[ drop , f 2array ] state ;


@@ -164,7 +164,7 @@ M: reader monad-of drop reader-monad ;
 M: reader-monad return drop '[ drop , ] reader ;
 M: reader-monad fail   "Fail" throw ;
 
 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 -- ) swap mcall ;
 


@@ -185,7 +185,7 @@ 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 _ '[ @ 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 ;
 : listen ( writer -- writer' ) run-writer [ 2array ] keep writer ;
 
 : pass ( writer -- writer' ) run-writer [ first2 ] dip swap call writer ;
 : listen ( writer -- writer' ) run-writer [ 2array ] keep writer ;