extra/monads/monads.factor

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