extra/monads/monads.factor

   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
   5 shuffle ;
   6 IN: monads
   7
   8 ! Functors
   9 GENERIC# fmap 1 ( functor quot -- functor' )
  10 GENERIC# <$ 1 ( functor quot -- functor' )
  11 GENERIC# $> 1 ( functor quot -- functor' )
  12
  13 ! Monads
  14
  15 ! Mixin type for monad singleton classes, used for return/fail only
  16 MIXIN: monad
  17
  18 GENERIC: monad-of ( mvalue -- singleton )
  19 GENERIC: return ( value singleton -- mvalue )
  20 GENERIC: fail ( value singleton -- mvalue )
  21 GENERIC: >>= ( mvalue -- quot )
  22
  23 M: monad return monad-of return ;
  24 M: monad fail   monad-of fail   ;
  25
  26 : bind ( mvalue quot -- mvalue' ) swap >>= call( quot -- mvalue ) ;
  27 : bind* ( mvalue quot -- mvalue' ) '[ drop @ ] bind ;
  28 : >>   ( mvalue k -- mvalue' ) '[ drop _ ] bind ;
  29
  30 :: lift-m2 ( m1 m2 f monad -- m3 )
  31     m1 [| x1 | m2 [| x2 | x1 x2 f monad return ] bind ] bind ;
  32
  33 :: apply ( mvalue mquot monad -- result )
  34     mvalue [| value |
  35         mquot [| quot |
  36             value quot call( value -- mvalue ) monad return
  37         ] bind
  38     ] bind ;
  39
  40 M: monad fmap over '[ @ _ return ] bind ;
  41
  42 ! 'do' notation
  43 : do ( quots -- result ) unclip [ call( -- mvalue ) ] curry dip [ bind ] each ;
  44
  45 ! Identity
  46 SINGLETON: identity-monad
  47 INSTANCE:  identity-monad monad
  48
  49 TUPLE: identity value ;
  50 INSTANCE: identity monad
  51
  52 M: identity monad-of drop identity-monad ;
  53
  54 M: identity-monad return drop identity boa ;
  55 M: identity-monad fail   "Fail" throw ;
  56
  57 M: identity >>= value>> '[ _ swap call( x -- y ) ] ;
  58
  59 : run-identity ( identity -- value ) value>> ;
  60
  61 ! Maybe
  62 SINGLETON: maybe-monad
  63 INSTANCE:  maybe-monad monad
  64
  65 SINGLETON: nothing
  66
  67 TUPLE: just value ;
  68 : just ( value -- just ) \ just boa ;
  69
  70 UNION: maybe just nothing ;
  71 INSTANCE: maybe monad
  72
  73 M: maybe monad-of drop maybe-monad ;
  74
  75 M: maybe-monad return drop just ;
  76 M: maybe-monad fail   2drop nothing ;
  77
  78 M: nothing >>= '[ drop _ ] ;
  79 M: just    >>= value>> '[ _ swap call( x -- y ) ] ;
  80
  81 : if-maybe ( maybe just-quot nothing-quot -- )
  82     pick nothing? [ 2nip call ] [ drop [ value>> ] dip call ] if ; inline
  83
  84 ! Either
  85 SINGLETON: either-monad
  86 INSTANCE:  either-monad monad
  87
  88 TUPLE: left value ;
  89 : left ( value -- left ) \ left boa ;
  90
  91 TUPLE: right value ;
  92 : right ( value -- right ) \ right boa ;
  93
  94 UNION: either left right ;
  95 INSTANCE: either monad
  96
  97 M: either monad-of drop either-monad ;
  98
  99 M: either-monad return  drop right ;
 100 M: either-monad fail    drop left ;
 101
 102 M: left  >>= '[ drop _ ] ;
 103 M: right >>= value>> '[ _ swap call( x -- y ) ] ;
 104
 105 : if-either ( value left-quot right-quot -- )
 106     [ [ value>> ] [ left? ] bi ] 2dip if ; inline
 107
 108 ! Arrays
 109 SINGLETON: array-monad
 110 INSTANCE:  array-monad monad
 111 INSTANCE:  array monad
 112
 113 M: array-monad return  drop 1array ;
 114 M: array-monad fail   2drop { } ;
 115
 116 M: array monad-of drop array-monad ;
 117
 118 M: array >>= '[ _ swap map concat ] ;
 119
 120 ! List
 121 SINGLETON: list-monad
 122 INSTANCE:  list-monad monad
 123 INSTANCE:  list monad
 124
 125 M: list-monad return drop 1list ;
 126 M: list-monad fail   2drop nil ;
 127
 128 M: list monad-of drop list-monad ;
 129
 130 M: list >>= '[ _ swap lazy-map lconcat ] ;
 131
 132 ! State
 133 SINGLETON: state-monad
 134 INSTANCE:  state-monad monad
 135
 136 TUPLE: state quot ;
 137 : state ( quot -- state ) \ state boa ;
 138
 139 INSTANCE: state monad
 140
 141 M: state monad-of drop state-monad ;
 142
 143 M: state-monad return drop '[ _ 2array ] state ;
 144 M: state-monad fail   "Fail" throw ;
 145
 146 : mcall ( x state -- y ) quot>> call( x -- y ) ;
 147
 148 M: state >>= '[ _ swap '[ _ mcall first2 @ mcall ] state ] ;
 149
 150 : get-st ( -- state ) [ dup 2array ] state ;
 151 : put-st ( value -- state ) '[ drop _ f 2array ] state ;
 152
 153 : run-st ( state initial -- value ) swap mcall second ;
 154
 155 : return-st ( value -- mvalue ) state-monad return ;
 156
 157 ! Reader
 158 SINGLETON: reader-monad
 159 INSTANCE:  reader-monad monad
 160
 161 TUPLE: reader quot ;
 162 : reader ( quot -- reader ) \ reader boa ;
 163 INSTANCE: reader monad
 164
 165 M: reader monad-of drop reader-monad ;
 166
 167 M: reader-monad return drop '[ drop _ ] reader ;
 168 M: reader-monad fail   "Fail" throw ;
 169
 170 M: reader >>= '[ _ swap '[ dup _ mcall @ mcall ] reader ] ;
 171
 172 : run-reader ( reader env -- value ) swap quot>> call( env -- value ) ;
 173
 174 : ask ( -- reader ) [ ] reader ;
 175 : local ( reader quot -- reader' ) swap '[ @ _ mcall ] reader ;
 176
 177 ! Writer
 178 SINGLETON: writer-monad
 179 INSTANCE:  writer-monad monad
 180
 181 TUPLE: writer value log ;
 182 : writer ( value log -- writer ) \ writer boa ;
 183
 184 M: writer monad-of drop writer-monad ;
 185
 186 M: writer-monad return drop { } writer ;
 187 M: writer-monad fail   "Fail" throw ;
 188
 189 : run-writer ( writer -- value log ) [ value>> ] [ log>> ] bi ;
 190
 191 M: writer >>= '[ [ _ run-writer ] dip '[ @ run-writer ] dip append writer ] ;
 192
 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 ;