自由モナドを使えば動的型付けでも多相的なモナド演算ができますよというお話

monad.scm

(import (gauche partcont)
        (scheme base)
        (scheme write))


;;; generic fmap

(define *fmap-methods*
  `((,list? . ,map)))

(define (fmap f x)
  (let loop ((ms *fmap-methods*))
    (if (null? ms)
        (error "unknown type")
        (if ((caar ms) x)
            ((cdar ms) f x)
            (loop (cdr ms))))))

(define (define-fmap pred? method)
  (set! *fmap-methods* `((,pred? . ,method) . ,*fmap-methods*)))



;;; free monad type

(define (make-unit x)                   ; make-unit : a -> Free f a
  `(unit . ,x))

(define (make-join m)                   ; make-join : f (Free f a) -> Free f a
  `(join . ,m))

(define (unit? obj)
  (and (pair? obj) (eq? (car obj) 'unit)))

(define (join? obj)
  (and (pair? obj) (eq? (car obj) 'join)))

(define (free-monad? obj)
  (or (unit? obj) (join? obj)))

(define (free-monad-fmap f m)
  (let ((v (cdr m)))
    (cond
     ((unit? m) (make-unit (f v)))
     ((join? m) (make-join (fmap (lambda (x) (fmap f x)) v))))))

(define-fmap free-monad? free-monad-fmap)



;;; option type

(define (make-some x)
  `(some . ,x))

(define (make-none)
  `(none))

(define (some? x)
  (and (pair? x)
       (eq? (car x) 'some)))

(define (none? x)
  (and (pair? x)
       (eq? (car x) 'none)))

(define (option? x)
  (or (some? x) (none? x)))

(define (option-fmap f o)
  (let ((v (cdr o)))
    (cond
     ((some? o) (make-some (f v)))
     ((none? o) (make-none)))))

(define-fmap option? option-fmap)



;;; monad operators

(define (unit x)
  (make-unit x))

(define (join m)
  (let ((v (cdr m)))
    (cond
     ((unit? m) v)
     ((join? m) (make-join (fmap join v))))))

(define (bind m f)
  (join (fmap f m)))


(define (lift x)                        ; lift : f a -> Free f a
  (make-join (fmap make-unit x)))



;;; syntax

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

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



;;; test

(define (p x)
  (write x)
  (newline)
  (flush-output-port)
  x)

(define (free-monad->list m)
  (let ((v (cdr m)))
    (cond
     ((unit? m) (list v))
     ((join? m) (apply append (map free-monad->list v))))))

(p
 (free-monad->list
  (p
   (reify
    (let* ((x (reflect (lift '(1 2))))
           (y (reflect (lift '(3 4 5)))))
      (+ x y))))))

; =>
; (join (join (unit . 4) (unit . 5) (unit . 6)) (join (unit . 5) (unit . 6) (unit . 7)))
; (4 5 6 5 6 7)

(define (free-monad->option m)
  (let ((v (cdr m)))
    (cond
     ((unit? m) (make-some v))
     ((join? m) (if (some? v)
                    (free-monad->option (cdr v))
                    (make-none))))))

(define (lookup key alist)
  (if (null? alist)
      (make-none)
      (if (eq? (caar alist) key)
          (make-some (cdar alist))
          (lookup key (cdr alist)))))

(define alist '((one . 1) (two . 2) (three . 3) (four . 4)))

(p
 (free-monad->option
  (reify
   (let* ((x (reflect (lift (lookup 'two alist))))
          (y (reflect (lift (lookup 'five alist)))))
     (cons x y)))))

; => (none)

(p
 (free-monad->option
  (reify
   (let* ((x (reflect (lift (lookup 'two alist))))
          (y (reflect (lift (lookup 'four alist)))))
     (cons x y)))))

; => (some 2 . 4)

本当はfmapを動的に型を見てディスパッチしてるのもよくない。全部をCoyonedaでくるむようにするとfmapの型をhomC a b -> homD (f a) (f b)にできる。ただし持ち下げの処理がめんどくさくなる。

でこれきせんせーによる改良 → https://gist.github.com/leque/a72a9839b91ebb496185