Monad on Scheme

Twitterでちらほら動的型付けでMonadなんてのが賑わっていたので、追随してみた。
CLで書かれていたのをScheme (Sagittarius)に書き直しただけなので非常に簡単ではあったが・・・
こんな感じ。

(import (rnrs) (clos user))

;; From following URLs
;; http://d.hatena.ne.jp/wasabiz/20121014/1350174261
;; http://basking-cat.blogspot.jp/2012/10/clojurestate.html
(define-syntax perform
  (syntax-rules ()
    ((_ ((name value)) expr ...)
     (fmap value (lambda (name) expr ...)))
    ((_ ((name value) . rest) expr ...)
     (bind value (lambda (name) (perform rest expr ...))))))

(define-generic bind)
(define-generic fmap)

;; List Monad
(define-method bind ((m <list>) f) (apply append (map f m)))
(define-method fmap ((m <list>) f) (map f m))

;; State Monad
(import (sagittarius object) (match))
(define-class <state> () ((run :init-keyword :run :reader state-run)))
(define (run-state m v) ((state-run m) v))
(define (eval-state m v) (car (run-state m v)))
(define (exec-state m v) (cadr (run-state m v)))

(define (make-state f) (make <state> :run f))

(define (get-state) (make-state (lambda (s) (list s s))))
(define (put-state) (make-state (lambda (_) (list '() x))))

(define-method bind ((m <state>) f)
  (make-state (lambda (s)
                (match (run-state m s)
                  ((a ss)
                   (run-state (f a) ss))))))

(define-method fmap ((m <state>) f)
  (make-state (lambda (s)
                (match (run-state m s)
                  ((a ss)
                   (list (f a) ss))))))

;; cursor
(define-class <cursor> ()
  ((x :init-keyword :x)
   (y :init-keyword :y)))
(define-method write-object ((c <cursor>) p)
  (format p "#<cursor (x ~a) (y ~a)>" (~ c 'x) (~ c 'y)))
(define (make-cursor x y) (make <cursor> :x x :y y))
(define (right n)
  (make-state (lambda (cursor)
                (let ((x (+ (~ cursor 'x) n)))
                  (list x (make-cursor x (~ cursor 'y)))))))
(define (down n)
  (make-state (lambda (cursor)
                (let ((y (+ (~ cursor 'y) n)))
                  (list y (make-cursor (~ cursor 'x) y))))))

(define (square n)
  (perform ((x (right n))
            (s (down x)))
    s))

(let* ((c (make-cursor 0 0))
       (es (exec-state (square 10) c)))
  (print c)
  (print es))

;; seqM and mapM
;; from https://gist.github.com/3889104
(define (seqM ms)
  (define (rec ms)
    (match ms
      ((m . ms)
       (if (null? ms)
           (fmap m (lambda (x) (cons x '())))
           (bind m (lambda (x) (fmap (rec ms) (lambda (y) (cons x y)))))))
      (_ '())))
  (if (null? ms)
      '()
      (rec ms)))

(define (mapM f ms) (seqM (map f ms)))

(define-class <maybe> () ((x :init-keyword :x :reader maybe-x)))
(define-method write-object ((m <maybe>) p)
  (format p "#<maybe ~s>" (maybe-x m)))
(define (make-maybe x) (make <maybe> :x x))
(define-method bind ((m <maybe>) f)
  (match (maybe-x m)
    ((:just . x) (f x))
    (:nothing (make-maybe :nothing))))

(define-method fmap ((m <maybe>) f)
  (make-maybe (match (maybe-x m)
                ((:just . x) (cons :just (f x)))
                (:nothing :nothing))))

;; Test
(define (buz xs)
  (define (bar x)
    (if (negative? x)
        (make-maybe :nothing)
        (make-maybe (cons :just (sqrt x)))))
  (mapM bar xs))

(print (buz '(1 4 9)))
(print (buz '(1 -4 9)))

Gaucheなら多分あまり手を入れなくても動くはず。TinyCLOSを持ってる処理系はキーワードの処理だけ何とかすれば、多少手を入れればいけるはず。
問題は、僕はMonadをよく分かっていないし、そのありがたみを享受したこともないので、こで何がうれしいのかいまいち分からない。Haskelやれってことか？