monad.scm

(define (then m k)
  (bind m (lambda (_) k)))

(define (state-unit a)
  (lambda (s) `(,a ,s)))

(define (state-bind m k)
  (lambda (s)
    (let* { [r (m s)]
            [a (car r)]
            [s- (cadr r)] }
      ((k a) s- ))))

(define (state-get s)
  `(,s ,s))

(define (state-put s)
  (lambda (_) `(() ,s)))

(define-syntax monad-context
  (syntax-rules (<- @ =)
    [(_ unit bind m) m]
    [(_ unit bind @ a) (unit a)]
    [(_ unit bind x = a k ...)
     (bind (unit a) (lambda (x) (monad-context unit bind k ...)))]
    [(_ unit bind x <- m k ...)
     (bind m (lambda (x) (monad-context unit bind k ...)))]
    [(_ unit bind @ a k ...)
     (bind (unit a) (lambda (_) (monad-context unit bind k ...)))]
    [(_ unit bind m k ...)
     (bind m (lambda (_) (monad-context unit bind k ...)))]))

(define state
  (monad-context state-unit state-bind
                 x <- state-get
                 @ (display x)
                 @ (newline)
                 (state-put (* x x))
                 y <- state-get
                 @ (display y)
                 @ (newline)))
(state 42)


(use srfi-9)

;polymorphic >>=


(define-record-type <just>
  (just a) just?
  (a just-a))

(define-record-type <nothing>
  (nothing) nothing?)

(define (maybe-unit a)
  (just a))

(define-method >>= ([x <just>] f)
  (f (just-a x)))

(define-method >>= ([x <nothing>] f)
  x)

(define (fail)
  (nothing))

(define maybe
  (monad-context maybe-unit >>=
    x <- (just 52)
    y = (* x x)
    @ (display y)
    @ (newline)))
;=> just 2704

(define maybe
  (monad-context maybe-unit >>=
    x <- (just 52)
    y = (* x x)
    (nothing)
    z = (* y y)
    @ (display z)))
;=>nothing