db4
Slava Pestov 2008-05-03 04:44:02 -05:00
parent 117f6dd804
commit 185eadf3be
6 changed files with 325 additions and 0 deletions

1
extra/monads/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -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

192
extra/monads/monads.factor Normal file
View File

@ -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 ;

1
extra/monads/summary.txt Normal file
View File

@ -0,0 +1 @@
Haskell-style monads

1
extra/monads/tags.txt Normal file
View File

@ -0,0 +1 @@
extensions

View File

@ -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 ;