1 ! Copyright (C) 2008 Slava Pestov
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: arrays kernel sequences sequences.deep splitting
4 accessors fry locals combinators namespaces lists lists.lazy
9 GENERIC# fmap 1 ( functor quot -- functor' )
10 GENERIC# <$ 1 ( functor quot -- functor' )
11 GENERIC# $> 1 ( functor quot -- functor' )
15 ! Mixin type for monad singleton classes, used for return/fail only
18 GENERIC: monad-of ( mvalue -- singleton )
19 GENERIC: return ( value singleton -- mvalue )
20 GENERIC: fail ( value singleton -- mvalue )
21 GENERIC: >>= ( mvalue -- quot )
23 M: monad return monad-of return ;
24 M: monad fail monad-of fail ;
26 : bind ( mvalue quot -- mvalue' ) swap >>= call( quot -- mvalue ) ;
27 : bind* ( mvalue quot -- mvalue' ) '[ drop @ ] bind ;
28 : >> ( mvalue k -- mvalue' ) '[ drop _ ] bind ;
30 :: lift-m2 ( m1 m2 f monad -- m3 )
31 m1 [| x1 | m2 [| x2 | x1 x2 f monad return ] bind ] bind ;
33 :: apply ( mvalue mquot monad -- result )
36 value quot call( value -- mvalue ) monad return
40 M: monad fmap over '[ @ _ return ] bind ;
43 : do ( quots -- result ) unclip [ call( -- mvalue ) ] curry dip [ bind ] each ;
46 SINGLETON: identity-monad
47 INSTANCE: identity-monad monad
49 TUPLE: identity value ;
50 INSTANCE: identity monad
52 M: identity monad-of drop identity-monad ;
54 M: identity-monad return drop identity boa ;
55 M: identity-monad fail "Fail" throw ;
57 M: identity >>= value>> '[ _ swap call( x -- y ) ] ;
59 : run-identity ( identity -- value ) value>> ;
62 SINGLETON: maybe-monad
63 INSTANCE: maybe-monad monad
68 : just ( value -- just ) \ just boa ;
70 UNION: maybe just nothing ;
73 M: maybe monad-of drop maybe-monad ;
75 M: maybe-monad return drop just ;
76 M: maybe-monad fail 2drop nothing ;
78 M: nothing >>= '[ drop _ ] ;
79 M: just >>= value>> '[ _ swap call( x -- y ) ] ;
81 : if-maybe ( maybe just-quot nothing-quot -- )
82 pick nothing? [ 2nip call ] [ drop [ value>> ] dip call ] if ; inline
85 SINGLETON: either-monad
86 INSTANCE: either-monad monad
89 : left ( value -- left ) \ left boa ;
92 : right ( value -- right ) \ right boa ;
94 UNION: either left right ;
95 INSTANCE: either monad
97 M: either monad-of drop either-monad ;
99 M: either-monad return drop right ;
100 M: either-monad fail drop left ;
102 M: left >>= '[ drop _ ] ;
103 M: right >>= value>> '[ _ swap call( x -- y ) ] ;
105 : if-either ( value left-quot right-quot -- )
106 [ [ value>> ] [ left? ] bi ] 2dip if ; inline
109 SINGLETON: array-monad
110 INSTANCE: array-monad monad
111 INSTANCE: array monad
113 M: array-monad return drop 1array ;
114 M: array-monad fail 2drop { } ;
116 M: array monad-of drop array-monad ;
118 M: array >>= '[ _ swap map concat ] ;
121 SINGLETON: list-monad
122 INSTANCE: list-monad monad
125 M: list-monad return drop 1list ;
126 M: list-monad fail 2drop nil ;
128 M: list monad-of drop list-monad ;
130 M: list >>= '[ _ swap lazy-map lconcat ] ;
133 SINGLETON: state-monad
134 INSTANCE: state-monad monad
137 : state ( quot -- state ) \ state boa ;
139 INSTANCE: state monad
141 M: state monad-of drop state-monad ;
143 M: state-monad return drop '[ _ 2array ] state ;
144 M: state-monad fail "Fail" throw ;
146 : mcall ( x state -- y ) quot>> call( x -- y ) ;
148 M: state >>= '[ _ swap '[ _ mcall first2 @ mcall ] state ] ;
150 : get-st ( -- state ) [ dup 2array ] state ;
151 : put-st ( value -- state ) '[ drop _ f 2array ] state ;
153 : run-st ( state initial -- value ) swap mcall second ;
155 : return-st ( value -- mvalue ) state-monad return ;
158 SINGLETON: reader-monad
159 INSTANCE: reader-monad monad
162 : reader ( quot -- reader ) \ reader boa ;
163 INSTANCE: reader monad
165 M: reader monad-of drop reader-monad ;
167 M: reader-monad return drop '[ drop _ ] reader ;
168 M: reader-monad fail "Fail" throw ;
170 M: reader >>= '[ _ swap '[ dup _ mcall @ mcall ] reader ] ;
172 : run-reader ( reader env -- value ) swap quot>> call( env -- value ) ;
174 : ask ( -- reader ) [ ] reader ;
175 : local ( reader quot -- reader' ) swap '[ @ _ mcall ] reader ;
178 SINGLETON: writer-monad
179 INSTANCE: writer-monad monad
181 TUPLE: writer value log ;
182 : writer ( value log -- writer ) \ writer boa ;
184 M: writer monad-of drop writer-monad ;
186 M: writer-monad return drop { } writer ;
187 M: writer-monad fail "Fail" throw ;
189 : run-writer ( writer -- value log ) [ value>> ] [ log>> ] bi ;
191 M: writer >>= '[ [ _ run-writer ] dip '[ @ run-writer ] dip append writer ] ;
193 : pass ( writer -- writer' ) run-writer [ first2 ] dip swap call( x -- y ) writer ;
194 : listen ( writer -- writer' ) run-writer [ 2array ] keep writer ;
195 : tell ( seq -- writer ) f swap writer ;