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

Free モナドを使うと `Functor f` からモナド則を満たす `Free f` が得られる。 [Freer Monads, More Extensible Effects](http://dl.acm.org/citation.cfm?doid=2804302.2804319) の Freer[^1] モナドを使うと、 `Functor` であることすら必要とせずモナドが得られると聞いたので Scheme （Gauche）で実装してみた。

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

[^1]: 元論文では `FFree`。

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

```hs
data Free f a = Pure a | Impure (f (Free f a))
```
これが次のようにして Monad のインスタンスになる。

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

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

```hs
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 クラスにおける射の合成](http://hackage.haskell.org/packages/archive/base/latest/doc/html/Control-Category.html#v:-62--62--62-)で、ここでは Kleisli 射を合成して `k'` をした後に `k` をする計算を作っている。

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

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

```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` な計算を入れておく。

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

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

```scheme
(use gauche.partcont)

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

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

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

```scheme
(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` しないといけないことに注意。

```scheme
(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` もできる。

```scheme
(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](http://docs.racket-lang.org/ts-reference/index.html) 的な、偽値と内容型の合併型（union type）の気持ちで表現してみる。

```scheme
;;; (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)))))
```

使ってみる。

```scheme
(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](http://practical-scheme.net/wiliki/wiliki.cgi?Scheme%3AExplicitMonad) の議論を参照）。 Free モナドであれば `return` の問題はなくなるが、引数に応じて `fmap` の実体を決めるのにオブジェクトシステムのようなものが欲しくなる。

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

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