/2016/08/27/200000.htmlinkar-us-i.hatenablog.com

上の記事で作ったモナドはグローバルなスタックに現在のモナドを積むというものでしたので、mlet*の終了と同時に現在使用しているモナドに関する情報が消滅してしまい、実際の評価が後で行われるStateモナドのようなモナドを作ることはできませんでした。

そこで、今回はScalaライクに暗黙引数を使ってモナドを作ります。

モナド自体の定義は前回と同様です。

(define-class <monad> ()
  ((return :init-keyword :return :getter monad-return)
   (bind :init-keyword :bind :getter monad-bind)))
(define-macro (defun/monad mproc args . body)
  (define mproc/monad
    (string->symbol (string-append (symbol->string mproc) "/monad")))
  `(begin
     (define ,mproc/monad
       (^(?monad)
         (^(,@args)
           ,@body)))
     (define-macro (,mproc . args)
       `((,,mproc/monad ?monad) ,@args))))

このマクロdefun/monadが今回のキモです。このマクロを使って、例えば

(defun/monad mreturn (x)
  ((monad-return ?monad) x))

というようにreturn文mreturnを定義すると、これが以下のように展開されます。

(define (mreturn/monad ?monad)
  (^(x)
    ((monad-return ?monad) x)))

(define-macro (mreturn x)
  ((mreturn/monad ?monad) x)

mreturn/monadがreturnの本体で、モナド?monadと引数xを受け取り、xをモナドに包んで返す関数となっています。

mreturnはmreturn/monadを呼び出すためのマクロで、現在のスコープにある?monadを捕まえて、mreturn/monadに暗黙的に渡すようになっています。
暗黙引数の頭に?が付いているのはHaskellを参考にしました。

これを使って同様に>>=に相当する関数mbindを定義します。

(defun/monad mbind (x f)
  ((monad-bind ?monad) x f))

また、defun/monadを使えば、任意のモナドに対する操作も簡単に定義することができます。

(defun/monad mfor (lst action)
  (if (null? lst)
      (mreturn ())
      (mlet* ((x (action (car lst)))
              (xs ((mfor/monad ?monad) (cdr lst) action)))
             (mreturn (cons x xs)))))

モナドが暗黙的に受け取れるようになったため、mlet*はモナドを引数に取らなくてもよくなります。

(define-syntax mlet1
  (syntax-rules ()
    ((_ var mexpr body)
     (mbind mexpr (^(var) body)))
    ((_ var mexpr body ...)
     (mbind mexpr (^(var) (mlet1 _ body ...))))))

(define-syntax mlet*
  (syntax-rules ()
    ((_ () body) body)
    ((_ () body body2 rest ...)
     (mlet1 _ body body2 rest ...))
    ((_ ((name mexpr) binds ...) body ...)
     (mlet1 name mexpr
       (mlet* (binds ...) body ...)))))

これを使って実際にモナドを動かしてみましょう。まずは前の例と全く同様のリストモナド、Maybeモナドです。

;; リストモナド
(define list-monad
  (make <monad>
    :return list
    :bind (^(xs f) (concatenate (map f xs)))))

;; Maybeモナド(というかand-letモナド)
(define maybe-monad
  (make <monad>
    :return identity
    :bind (^(mvalue f) (if (eq? mvalue #f) #f (f mvalue)))))

(let ((?monad list-monad))
  (mlet*
   ((x '(1 2 3 4 5))
    (y '(2 4 6 8 9)))
   (mreturn (cons x y))))
;; =>
;; ((1 . 2) (1 . 4) (1 . 6) (1 . 8) (1 . 9)
;;  (2 . 2) (2 . 4) (2 . 6) (2 . 8) (2 . 9)
;;  (3 . 2) (3 . 4) (3 . 6) (3 . 8) (3 . 9)
;;  (4 . 2) (4 . 4) (4 . 6) (4 . 8) (4 . 9)
;;  (5 . 2) (5 . 4) (5 . 6) (5 . 8) (5 . 9))

(let ((?monad maybe-monad))
  (mlet*
   ((x 1)
    (y 2))
   (mreturn (+ x y))))
;; => 3

(let ((?monad  maybe-monad))
  (mlet*
   ((x #f)
    (y 2))
   (mreturn (+ x y))))
;; => #f

モナドを現在のスコープに束縛するようになったので、Stateモナドを作ることもできます。

(define (state-return x)
  (^(s) (cons x s)))

(define (state-bind mx f)
  (^(s)
    (let* ((res1 (mx s))
           (x1 (car res1))
           (s1 (cdr res1)))
      ((f x1) s1))))

(define state-monad
  (make <monad>
    :return state-return
    :bind state-bind))

(define (state-get)
  (define (state-get-inner s)
    (cons s s))
  state-get-inner)

(define (state-put s)
  (define (state-put-inner _)
    (cons #f s))
  state-put-inner)

(define (state-modify f)
  (state-bind (state-get)
              (^(s) (state-put (f s)))))

実際に実行してみましょう。以下の例は、現在の状態をそのまま返しつつ、状態に1を足すアクションです。
初期状態には5が与えられています。

(let ((?monad state-monad))
  ((mlet*
    ((s (state-get)))
    (state-put (+ s 1))
    (mreturn s))
   5 ;; (mlet* ..)の結果は関数となり、初期状態を引数として与える
   ))
;; => (5 . 6)

先ほど定義したmforを使うこともできます。以下は与えられた状態に0, .., 4を足すアクションです。

(let ((?monad state-monad))
  ((mlet*
    ()
    (mfor
     (iota 5)
     (^(i)
       (state-modify (pa$ + i)))))
   0))
;; => ((#f #f #f #f #f) . 10)