より自由なFreerモナドをSchemeに

Free モナドを使うと Functor f からモナド則を満たす Free f が得られる。 Freer Monads, More Extensible Effects の Freer¹ モナドを使うと、 Functor であることすら必要とせずモナドが得られると聞いたので Scheme （Gauche）で実装してみた。

（ちなみに、 Freer モナドの定義は2013年ごろに話題になった Operational モナドと同一である。 Operational モナドを知っている人にはこの記事で得られるものは少ないかもしれない。 Operational については例えば Freeモナドを超えた！？operationalモナドを使ってみようなどを参照。元論文はさらに Operational モナドの効率的な実現法や Extensible Effects との組み合わせについて扱っている）

Free の定義は下のようになっている。

data Free f a = Pure a | Impure (f (Free f a))

これが次のようにして Monad のインスタンスになる。

instance Functor f => Monad (Free f) where
    return = Pure
    Pure a >>= f = f a
    Impure m >>= f = Impure (fmap (>>= f) m)

今回のお題である Freer の定義は以下の通り。

data Freer f a where
    Pure :: a -> Freer f a
    Impure :: f x -> (x -> Freer f a) -> Freer f a

instance Monad (Freer f a) where
    return = Pure
    Pure x >>= k = k x
    Impure fx k' >>= k = Impure fx (k' >>> k)

Pure に関しては Free と同じだが、 Impure の方は f x の値とそれを使う計算（継続）を合わせて持ち回り、 >>= で値を計算するのではなく継続を組み立てるようにしている。 >>> は Category クラスにおける射の合成で、ここでは Kleisli 射を合成して k' をした後に k をする計算を作っている。

先述の通り、この定義は Operational モナドと同一だが、元論文では Free よりも一般的である（= Functor 制約を含め、何の制約も課さない）という意味で Freer と呼んでいる。

この定義を Scheme に写すと下のようになる。

(use gauche.record)
(use util.match)

;;; data Freer f a where
;;;   Pure   :: a -> Freer f a
;;;   Impure :: f x -> (x -> Freer f a) -> Freer f a
(define-record-type <pure> pure pure?
  (value pure-value))

(define-method write-object ((x <pure>) port)
  (format port "#<pure ~S>" (pure-value x)))

(define-record-type <impure> impure impure?
  (value impure-value)
  (continuation impure-continuation))

(define-method write-object ((x <impure>) port)
  (format port "#<impure ~S>"
          (impure-value x)))

(define (freer? x)
  (or (pure? x)
      (impure? x)))

;;; bind :: Freer f a -> (a -> Freer f b) -> Freer f b
(define (bind m k)
  (match m
    (($ <pure> v)
     (k v))
    (($ <impure> v k~)
     (impure v (kleisli>>> k~ k)))))

;;; kleisli>>> :: (a -> Freer f b) -> (b -> Freer f c) -> (a -> Freer f c)
(define (kleisli>>> f g)
  (lambda (x)
    (bind (f x) g)))

f a の表す副作用を Freer f a に持ち上げる手続きも定義する。 f a の入る場所は Impure しかないので、残りの部分には何もしない a -> f a な計算を入れておく。

;;; lift :: f a -> Freer f a
(define (lift x)
  (impure x pure))

あとは bind と pure を組み合わせて頑張って書いていってもよいけれど、例のごとく限定継続を使って直接形式のモナドにする。

(use gauche.partcont)

(define-syntax reify
  (syntax-rules ()
    ((_ expr)
     (reset (pure expr)))))

(define (reflect m)
  (shift k
    (bind m k)))

モナド演算は Freer に対して定義する。

(define (sequence ms)
  (reify
   (match ms
     (() '())
     ((mx . ms~)
      (let* ((x (reflect mx))
             (xs (reflect (sequence ms~))))
        (cons x xs))))))

リストに対する解釈を定義する。 <impure> の中の k を適用しただけだと List a ではなく Free List a になってしまうので、さらに run-list しないといけないことに注意。

(use srfi-1)

;;; run-list :: Free List a -> List a
(define (run-list m)
  (match m
    (($ <pure> v)
     (list v))
    (($ <impure> v k)
     (append-map (compose run-list k) v))))

Haskell の do を (reify ...) に、 <- を reflect にして、リストを適当に lift すれば動く。副作用の順番に意味があるので let ではなく let* を使う。 sequence もできる。

(print
 (run-list
  (reify
   (let* ((x (reflect (lift '(1 2 3))))
          (y (reflect (lift '(a b c)))))
     (vector x y)))))
;; -| (#(1 a) #(1 b) #(1 c) #(2 a) #(2 b) #(2 c) #(3 a) #(3 b) #(3 c))

(print
 (run-list
  (sequence (list (lift '(1 2 3))
                  (lift '(4 5))))))
;; -| ((1 4) (1 5) (2 4) (2 5) (3 4) (3 5))

(print
 (run-list (sequence (list (pure 1) (pure 2)))))
;; -| ((1 2))

リストだけでなくオプション型のモナドも試してみる。どうせなので、和型（sum type）ではなく、 Typed Racket 的な、偽値と内容型の合併型（union type）の気持ちで表現してみる。

;;; (define-type (Option A) (U A False))
;;; run-option :: Free Option a -> Option a
(define (run-option m)
  (match m
    (($ <pure> v)
     v)
    (($ <impure> #f k)
     #f)
    (($ <impure> v k)
     (run-option (k v)))))

使ってみる。

(print
 (run-option
  (reify
   (let* ((x (reflect (lift (find (cut eqv? <> 1) '(1 2 3)))))
          (y (reflect (lift (find (cut eqv? <> 'b) '(a b c))))))
     (vector x y)))))
;; -| #(1 b)

(print
 (run-option (sequence (list (pure 1) (pure 2)))))
;; -| (1 2)

(print
 (run-option (sequence (list (lift 1) (pure 2)))))
;; -| (1 2)

(print
 (run-option (sequence (list (lift 1) (pure #f)))))
;; -| (1 #f)

(print
 (run-option (sequence (list (lift #f) (pure 2)))))
;; -| #f

(print
 (run-option (sequence (list (pure 1) (lift #f)))))
;; -| #f

ちゃんと動く。 pure な #f と impure な #f を区別できることにも注目。

Scheme でモナドを書こうとするとメタ情報が足りないために、文脈に応じて return の実体を決めるという Haskell 的な（または Scala で implicit パラメータを使った場合の）やり方が使えない（例えば Scheme:ExplicitMonad の議論を参照）。 Free モナドであれば return の問題はなくなるが、引数に応じて fmap の実体を決めるのにオブジェクトシステムのようなものが欲しくなる。

Freer モナドであれば、モナド演算では計算を組み立てるだけで、最後に run-list や run-option で適当な解釈を与えるだけなので、魔法は必要ない。

この記事で使用したコードは https://gist.github.com/leque/a72a9839b91ebb496185 に置いてある。同様のものを OCaml で実装したものも https://gist.github.com/leque/147095bd992df351305a 置いてある。 OCaml も implicit パラメータがなくてモナモナしにくところがあるが、 Freer モナドだとけっこう使いやすいのではないだろうか。

1. 元論文では FFree。 ↩