Monads

diff --git a/extra/monads/authors.txt b/extra/monads/authors.txt
new file mode 100644 (file)
index 0000000..1901f27
--- /dev/null
+++ b/extra/monads/authors.txt
@@ -0,0 +1 @@
+Slava Pestov

diff --git a/extra/monads/monads-tests.factor b/extra/monads/monads-tests.factor
new file mode 100644 (file)
index 0000000..52cdc47
--- /dev/null
+++ b/extra/monads/monads-tests.factor
@@ -0,0 +1,128 @@
+USING: tools.test monads math kernel sequences lazy-lists promises ;
+IN: monads.tests
+
+[ 5 ] [ 1 identity-monad return [ 4 + ] fmap run-identity ] unit-test
+[ "OH HAI" identity-monad fail ] must-fail
+
+[ 666 ] [
+    111 just [ 6 * ] fmap [ ] [ "OOPS" throw ] if-maybe
+] unit-test
+
+[ nothing ] [
+    111 just [ maybe-monad fail ] bind
+] unit-test
+
+[ 100 ] [
+    5 either-monad return [ 10 * ] [ 20 * ] if-either
+] unit-test
+
+[ T{ left f "OOPS" } ] [
+    5 either-monad return >>= [ drop "OOPS" either-monad fail ] swap call
+] unit-test
+
+[ { 10 20 30 } ] [
+    { 1 2 3 } [ 10 * ] fmap
+] unit-test
+
+[ { } ] [
+    { 1 2 3 } [ drop "OOPS" array-monad fail ] bind
+] unit-test
+
+[ 5 ] [
+    5 state-monad return "initial state" run-st
+] unit-test
+
+[ 8 ] [
+    5 state-monad return [ 3 + state-monad return ] bind
+    "initial state" run-st
+] unit-test
+
+[ 8 ] [
+    5 state-monad return >>=
+    [ 3 + state-monad return ] swap call
+    "initial state" run-st
+] unit-test
+
+[ 11 ] [
+    f state-monad return >>=
+    [ drop get-st ] swap call
+    11 run-st
+] unit-test
+
+[ 15 ] [
+    f state-monad return
+    [ drop get-st ] bind
+    [ 4 + put-st ] bind
+    [ drop get-st ] bind
+    11 run-st
+] unit-test
+
+[ 15 ] [
+    {
+        [ f return-st ]
+        [ drop get-st ]
+        [ 4 + put-st ]
+        [ drop get-st ]
+    } do
+    11 run-st
+] unit-test
+
+[ nothing ] [
+    {
+        [ "hi" just ]
+        [ " bye" append just ]
+        [ drop nothing ]
+        [ reverse just ]
+    } do
+] unit-test
+
+LAZY: nats-from ( n -- list )
+    dup 1+ nats-from cons ;
+
+: nats 0 nats-from ;
+
+[ 3 ] [
+    {
+        [ nats ]
+        [ dup 3 = [ list-monad return ] [ list-monad fail ] if ]
+    } do car
+] unit-test
+
+[ 9/11 ] [
+    {
+        [ ask ]
+    } do 9/11 run-reader
+] unit-test
+
+[ 8 ] [
+    {
+        [ ask ]
+        [ 3 + reader-monad return ]
+    } do
+    5 run-reader
+] unit-test
+
+[ 6 ] [
+    f reader-monad return [ drop ask ] bind [ 1 + ] local 5 run-reader
+] unit-test
+
+[ f { 1 2 3 } ] [
+    5 writer-monad return
+    [ drop { 1 2 3 } tell ] bind
+    run-writer
+] unit-test
+
+[ T{ identity f 7 } ]
+[
+    4 identity-monad return
+    [ 3 + ] identity-monad return
+    identity-monad apply
+] unit-test
+
+[ nothing ] [
+    5 just nothing maybe-monad apply
+] unit-test
+
+[ T{ just f 15 } ] [
+    5 just [ 10 + ] just maybe-monad apply
+] unit-test

diff --git a/extra/monads/monads.factor b/extra/monads/monads.factor
new file mode 100644 (file)
index 0000000..0f4138c
--- /dev/null
+++ b/extra/monads/monads.factor
@@ -0,0 +1,192 @@
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel sequences sequences.deep splitting
+accessors fry locals combinators namespaces lazy-lists
+shuffle ;
+IN: monads
+
+! Functors
+GENERIC# fmap 1 ( functor quot -- functor' ) inline
+
+! Monads
+
+! Mixin type for monad singleton classes, used for return/fail only
+MIXIN: monad
+
+GENERIC: monad-of ( mvalue -- singleton )
+GENERIC: return ( string 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 ;
+
+:: lift-m2 ( m1 m2 f monad -- m3 )
+    m1 [| x1 | m2 [| x2 | x1 x2 f monad return ] bind ] bind ;
+
+:: apply ( mvalue mquot monad -- result )
+    mvalue [| value |
+        mquot [| quot |
+            value quot call monad return
+        ] bind
+    ] bind ;
+
+M: monad fmap over '[ @ , return ] bind ;
+
+! 'do' notation
+: do ( quots -- result ) unclip dip [ bind ] each ;
+
+! Identity
+SINGLETON: identity-monad
+INSTANCE:  identity-monad monad
+
+TUPLE: identity value ;
+INSTANCE: identity monad
+
+M: identity monad-of drop identity-monad ;
+
+M: identity-monad return drop identity boa ;
+M: identity-monad fail   "Fail" throw ;
+
+M: identity >>= value>> '[ , _ call ] ;
+
+: run-identity ( identity -- value ) value>> ;
+
+! Maybe
+SINGLETON: maybe-monad
+INSTANCE:  maybe-monad monad
+
+SINGLETON: nothing
+
+TUPLE: just value ;
+: just \ just boa ;
+
+UNION: maybe just nothing ;
+INSTANCE: maybe monad
+
+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 ] ;
+
+: if-maybe ( maybe just-quot nothing-quot -- )
+    pick nothing? [ 2nip call ] [ drop [ value>> ] dip call ] if ; inline
+
+! Either
+SINGLETON: either-monad
+INSTANCE:  either-monad monad
+
+TUPLE: left value ;
+: left \ left boa ;
+
+TUPLE: right value ;
+: right \ right boa ;
+
+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: left  >>= '[ drop , ] ;
+M: right >>= value>> '[ , _ call ] ;
+
+: if-either ( value left-quot right-quot -- )
+    [ [ value>> ] [ left? ] bi ] 2dip if ; inline
+
+! Arrays
+SINGLETON: array-monad
+INSTANCE:  array-monad monad
+INSTANCE:  array monad
+
+M: array-monad return  drop 1array ;
+M: array-monad fail   2drop { } ;
+
+M: array monad-of drop array-monad ;
+
+M: array >>= '[ , _ map concat ] ;
+
+! List
+SINGLETON: list-monad
+INSTANCE:  list-monad monad
+INSTANCE:  list monad
+
+M: list-monad return drop 1list ;
+M: list-monad fail   2drop nil ;
+
+M: list monad-of drop list-monad ;
+
+M: list >>= '[ , _ lmap lconcat ] ;
+
+! State
+SINGLETON: state-monad
+INSTANCE:  state-monad monad
+
+TUPLE: 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 fail   "Fail" throw ;
+
+: mcall quot>> call ;
+
+M: state >>= '[ , _ '[ , mcall first2 @ mcall ] state ] ;
+
+: get-st ( -- state ) [ dup 2array ] state ;
+: put-st ( value -- state ) '[ drop , f 2array ] state ;
+
+: run-st ( state initial -- ) swap mcall second ;
+
+: return-st state-monad return ;
+
+! Reader
+SINGLETON: reader-monad
+INSTANCE:  reader-monad monad
+
+TUPLE: 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 fail   "Fail" throw ;
+
+M: reader >>= '[ , _ '[ dup , mcall @ mcall ] reader ] ;
+
+: run-reader ( reader env -- ) swap mcall ;
+
+: ask ( -- reader ) [ ] reader ;
+: local ( reader quot -- reader' ) swap '[ @ , mcall ] reader ;
+
+! Writer
+SINGLETON: writer-monad
+INSTANCE:  writer-monad monad
+
+TUPLE: writer value log ;
+: writer \ writer boa ;
+
+M: writer monad-of drop writer-monad ;
+
+M: writer-monad return drop { } writer ;
+M: writer-monad fail   "Fail" throw ;
+
+: run-writer ( writer -- value log ) [ value>> ] [ log>> ] bi ;
+
+M: writer >>= '[ , run-writer _ '[ @ run-writer ] dip append writer ] ;
+
+: pass ( writer -- writer' ) run-writer [ first2 ] dip swap call writer ;
+: listen ( writer -- writer' ) run-writer [ 2array ] keep writer ;
+: tell ( seq -- writer ) f swap writer ;

diff --git a/extra/monads/summary.txt b/extra/monads/summary.txt
new file mode 100644 (file)
index 0000000..359722c
--- /dev/null
+++ b/extra/monads/summary.txt
@@ -0,0 +1 @@
+Haskell-style monads

diff --git a/extra/monads/tags.txt b/extra/monads/tags.txt
new file mode 100644 (file)
index 0000000..f427429
--- /dev/null
+++ b/extra/monads/tags.txt
@@ -0,0 +1 @@
+extensions

diff --git a/extra/shuffle/shuffle.factor b/extra/shuffle/shuffle.factor
index 33587bb7fafa40f2a4833f2ddf0e9dbc2af6d852..89522d1f76b685fefe88f0c8f1baee3458a4ff80 100644 (file)
--- a/extra/shuffle/shuffle.factor
+++ b/extra/shuffle/shuffle.factor
@@ -5,6 +5,8 @@ USING: kernel sequences namespaces math inference.transforms
 
 IN: shuffle
 
+: 2dip -rot 2slip ; inline
+
 MACRO: npick ( n -- ) 1- dup saver [ dup ] rot [ r> swap ] n*quot 3append ;
 
 MACRO: ndup ( n -- ) dup [ npick ] curry n*quot ;