これは、Schemeが動的型付けであるがゆえの限界なのだろうか。

(なお、別の解として、returnされた値は最終的にどこかで使われるのだし、 使う場所ではどの型を期待してるかわかっているのだから、その時点でディスパッチしてやる、 という賢い手がある。より自由なFreerモナドをSchemeに参照。)

```(define-monad Maybe
(unitM (x)   (cons 'Just x))
(bindM (m f) (match m
('Nothing 'Nothing)
(('Just . x) (f x))))
(failM (x)   'Nothing)
(zeroM ()    'Nothing)
(plusM (p q) (if (eq? p 'Nothing) q p))
)
```

unitM, bindM, failM, zeroM, plusM はそれぞれHaskellのreturn, >>=, fail, mzero, mplusに相当する。

```gosh> (unitM 'x)
*** ERROR: unitM: monad is not expected
```

```gosh> (Maybe (unitM 'x))
(Just . x)
```

```(define-class <sheep> ()
((name   :init-keyword :name)
(father :init-keyword :father)
(mother :init-keyword :mother)))

(define-method write-object ((s <sheep>) out)
(format out "#<sheep ~a>" (ref s 'name)))

(define (sheep name . opts)
(let-optionals* opts ((father #f) (mother #f))
(make <sheep> :name name :father father :mother mother)))

(define (father s)
(cond ((ref s 'father) => unitM)
(else 'Nothing)))

(define (mother s)
(cond ((ref s 'mother) => unitM)
(else 'Nothing)))

(define (mothers-paternal-grandfather s)
(letM* ((m  <- (mother s))
(gf <- (father m)))
(father gf)))

;; 何匹か羊を作っておく
(define mary (sheep 'mary))
(define john (sheep 'john adam #f))
(define mike (sheep 'mike #f   mary))
(define beth (sheep 'beth #f   mary))
(define suze (sheep 'suze john beth))
(define don  (sheep 'don  mike beth))
(define duke (sheep 'duke don  suze))
```

```gosh> (Maybe (mothers-paternal-grandfather duke))
gosh> (Maybe (mothers-paternal-grandfather don))
Nothing
```

## 汎用モナド操作

```;; Haskellのsequence
;; seqM :: [m a] -> m [a]
(define (seqM ms)
(define (mcons p q)
(bindM p (lambda (x) (bindM q (lambda (y) (unitM (cons x y)))))))
(fold-right mcons (unitM '()) ms))

;; mapM :: (a -> m b), [a] -> m [b]
(define (mapM proc args)
(seqM (map proc args)))

;; foldM :: (a, b -> m a), a, [b] -> m a
(define (foldM proc seed lis)
(if (null? lis)
(unitM seed)
(bindM (proc (car lis) seed)
(lambda (seed2) (foldM proc seed2 (cdr lis))))))
```

ここにある例：

```(define (baz xs)
(define (bar x)
(if (>= x 0)
(unitM (sqrt x))
(failM "I like positive")))
(Maybe (mapM bar xs)))

gosh> (baz '(1 4 9))
(Just 1.0 2.0 3.0)
gosh> (baz '(1 -4 9))
Nothing
```

```(define-monad State
(unitM (x)   (lambda (s) (values x s)))
(bindM (m f) (lambda (s)
((f val) s*))))
(getM  ()    (lambda (s) (values s s)))
(putM  (s)   (lambda (_) (values #f s)))
(runM  (m init) (m init)))
```

そして、これは木をトラバースして、葉を訪問順の番号に置き換えた 新たな木を構成するプログラムである。

```(define (number-tree tree)
(if (pair? tree)
(letM* ((left  <- (number-tree (car tree)))
(right <- (number-tree (cdr tree))))
(unitM (cons left right)))
(letM* ((n     <- (getM))
(_     <- (putM (+ n 1))))
(unitM n))))
```

```gosh> (State (runM (number-tree '(((a . b) . c) (d . e) . f)) 0))
(((0 . 1) . 2) (3 . 4) . 5)
6
```

```(define (number-tree tree)
(State
(if (pair? tree)
(letM* ((left  <- (number-tree (car tree)))
(right <- (number-tree (cdr tree))))
(unitM (cons left right)))
(letM* ((n     <- (getM))
(_     <- (putM (+ n 1))))
(unitM n)))))
```

```(define-monad List
(unitM (x)   (list x))
(bindM (m f) (append-map f m))
(failM (_)   '())
(zeroM ()    '())
(plusM (p q) (append p q))
)
```

```(use util.match)

(define (parse-hex-digit parsed ch)
(match parsed
(('Hex n) (if (char-set-contains? #[0-9a-fA-F] ch)
(unitM `(Hex ,(+ (* n 16) (digit->integer ch 16))))
(zeroM)))
(_ (zeroM))))

(define (parse-digit parsed ch)
(match parsed
(('Digit n) (if (char-numeric? ch)
(unitM `(Digit ,(+ (* n 10) (digit->integer ch))))
(zeroM)))
(_ (zeroM))))

(define (parse-word parsed ch)
(match parsed
(('Word s)  (if (char-alphabetic? ch)
(unitM `(Word ,(string-append s (string ch))))
(zeroM)))
(_ (zeroM))))

(define (parse ch parsed)
(plusM (parse-hex-digit parsed ch)
(plusM (parse-digit parsed ch)
(parse-word parsed ch))))

(define (parse-arg str)
(letM* ((List init <- (plusM (unitM '(Hex 0))
(plusM (unitM '(Digit 0))
(unitM '(Word ""))))))
(foldM parse init (string->list str))))
```

```gosh> (parse-arg "123")
((Hex 291) (Digit 123))
gosh> (parse-arg "123ab")
((Hex 74667))
gosh> (parse-arg "cafebabe")
((Hex 3405691582) (Word "cafebabe"))
gosh> (parse-arg "cafeba99")
((Hex 3405691545))
gosh> (parse-arg "cafebaz9")
()
```

```(use util.match)

(unitM (x) (lambda (count) (cons count x)))
(bindM (m f)
(lambda (count)
(match-let1 (newcount . val) (m count)
((f val) newcount))))
(runM  (m init-count) (m init-count))
)

(define (incr n) (cons (+ n 1) n))

(define (make-node val kids)
(letM* ((count <- incr))
(unitM (list 'Node count val kids))))

(define (build-btree depth)
(if (zero? depth)
(make-node depth '())
(letM* ((left  <- (build-btree (- depth 1)))
(right <- (build-btree (- depth 1))))
(make-node depth (list left right)))))
```

```gosh> (Numbered (runM (build-btree 3) 100))
(115
Node 114 3
((Node 106 2
((Node 102 1
((Node 100 0 ())
(Node 101 0 ())))
(Node 105 1
((Node 103 0 ())
(Node 104 0 ())))))
(Node 113 2
((Node 109 1
((Node 107 0 ())
(Node 108 0 ())))
(Node 112 1
((Node 110 0 ())
(Node 111 0 ())))))))
```

```(define-monad IO
(unitM (x)       x)
(bindM (m f)     (f m))
(put-charM (ch)  (write-char ch))
(put-lineM (str) (print str))
)

(define (f)
(IO
(letM* (( (put-lineM "Enter a number:") )
(all-n <- (unitM (iota n 1)))
(evens <- (List
(letM* ((i <- all-n))
(if (even? i) (unitM i) (failM "odd")))))
)
(unitM evens))))
```

## 実装

```(define-module util.monad
(use util.match)
(use util.list)
(use srfi-1)
(use gauche.parameter)
Identity Maybe List State IO
unitM bindM failM zeroM plusM runM getM putM
seqM mapM foldM)
)

(make-parameter (lambda (key . args)
(errorf "~a: monad is not expected" key))))

(syntax-rules ()
((_ name : super (key args . exprs) ...)
(begin
(define-method key args
(let ((cmd-alist `((key . ,(lambda args . exprs)) ...)))
'name
(lambda (selector . rest)
(cond ((assq selector cmd-alist)
=> (lambda (p) (apply (cdr p) rest)))
=> (cut apply <> selector rest))
(else
(errorf "Monad ~a doesn't support the operation ~s"
'name selector))))))
(define-syntax name
(syntax-rules ()
((_ . body)
. body))))))
((_ name (key args . exprs) ...)
))

(define-syntax letM*
(syntax-rules ()
((letM* () expr)
expr)
((letM* ((var <- init) . more) expr)
(bindM init (lambda (var) (letM* more expr))))
((letM* ((m var <- init) . more) expr)
(m (bindM init (lambda (var) (letM* more expr)))))
((letM* ((action) . more) expr)
(bindM action (lambda (_) (letM* more expr))))
((letM* ((m action) . more) expr)
(m (bindM action (lambda (_) (letM* more expr)))))
))

;; base class
(failM (x) (error x)))

;; Monad definitions and operation definitions comes after this ...

```

## コメント、議論

teranishi(2005/08/17 07:31:20 PDT):なるほど、型を陽に渡す方法がありましたか。勉強になります。

```(define (liftM f)
(lambda args (bindM (seqM args) (compose unitM (apply\$ f)))))

(define-syntax define-StateT
(syntax-rules ()
((_ name m)
(unitM (a)   (lambda (s) (m (unitM (cons a s)))))
(bindM (x f) (lambda (s) (m (letM* ((ret <- (name (x s))))
(name ((f (car ret)) (cdr ret)))))))
(failM (x)   (lambda (_) (m (failM x))))
(getM  ()    (lambda (s) (m (unitM (cons s s)))))
(putM  (s)   (lambda (_) (m (unitM (cons #f s)))))
(runM  (x init) (x init))
(evalStateT (x init) (m ((liftM car) (name (x init)))))
(zeroM ()    (lambda (_) (m (zeroM))))
(plusM (p q) (lambda (s) (m (plusM (name (p s)) (name (q s))))))))))

(define-StateT NDS List)
```

Shiro(2005/08/17 17:22:26 PDT): そうか、やっぱりパラメタライズしようとすると面倒ですね。 モナド名をマクロにするのは見た目がいいかなと思ってやったんですが、そうすると 「新たなモナドを生成する機構」を全てマクロのドメインに置かないとならなくなるのか… ここに出す前に試していたバージョンでは、モナド自体は実行時オブジェクトで with-monadという構文を使って切替えるようにしてました。それだとたぶん 新たなモナドを生成してゆくのは楽になるかな? それともこれが実行時にコンテキストを切替えてゆくという方法の限界なのかな?

teranishi(2005/08/19 18:35:19 PDT): モナド変換子なんて私はほとんど使いませんし、 使うにしても別の名前を付ければ済む話なので、別にこのままでも構わないと思います。 ただ、特定のモナドの特定の関数を取り出せる方法があるとありがたいですね。 (上のdefine-StateTのbindM,plusMの定義が簡単に書けるので)