Monads
parent
117f6dd804
commit
185eadf3be
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
|
@ -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
|
|
@ -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 ;
|
|
@ -0,0 +1 @@
|
|||
Haskell-style monads
|
|
@ -0,0 +1 @@
|
|||
extensions
|
|
@ -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 ;
|
||||
|
|
Loading…
Reference in New Issue