さっきまでなんとなく、気がついたら書いていた。

monad.lisp

(ql:quickload :optima)
(defpackage :monad
  (:use :common-lisp :optima)
  (:export :bind :just :none :do-monad))
(in-package :monad)

;; return
(defgeneric unit-m (type x))

;; >>=
(defgeneric bind (m func))
(defun binds (m &rest funcs)
  (if funcs
      (reduce #'bind (cons m funcs))
      m))

;; >>
(defun then (m1 m2)
  (bind m1 
	(lambda (_) (declare (ignore _)) m2)))

(defun thens (m1 &rest rest-m2)
  (let ((first (car rest-m2)))
    (if first
	(apply #'thens (cons (then m1 first) (cdr rest-m2)))
	m1)))


(defmacro do-monad (type &body body)
  (let ((_ (gensym)))
    (let ((first (car body))
	  (rest (cdr body)))
      (let ((unit-m-first (unit-m-add-types type first)))
	(match unit-m-first
	  ((list 'setm arg monad-proc)
	   `(binds ,monad-proc
		   ,(if rest
			`(lambda (,arg)
			   (do-monad ,type ,@rest)))))
	  (_
	   (if (null rest)
	       unit-m-first
 	       `(binds ,unit-m-first
		       (lambda (,_)
			 (declare (ignore ,_))
			 (do-monad ,type ,@rest))))))))))
  
(defun unit-m-add-types (type list)
  (let ((first (car list))
	(rest (cdr list)))
    (cond ((null list) nil)
	  ((eq first 'do-monad) list)
	  ((eq first 'unit-m)
	   `(unit-m ,type ,@(unit-m-add-types type rest)))
	  ((listp first)
	   (cons (unit-m-add-types type first)
		 (unit-m-add-types type rest)))
	  (t (cons first (unit-m-add-types type rest))))))


;; option 
(defstruct option)
(defstruct (just (:constructor just (content))
		 (:include option))
  content)
(defstruct (none (:constructor none)
		 (:include option)))

(defmethod unit-m ((type (eql 'option)) x)
  (just x))

(defmethod bind ((m option) proc-returning-option)
  (match m
    ((just :content x) (funcall proc-returning-option x))
    ((none) (none))))

;; Either
(defstruct either)

(defstruct (right (:constructor right (value))
		  (:include either))
  value)

(defstruct (left (:constructor left (value))
		 (:include either))
  value)

(defmethod unit-m ((type (eql 'either)) x)
  (right x))

(defmethod bind ((either either) proc-returning-either)
  (match either
    ((right :value value) (funcall proc-returning-either value))
    ((left :value _) either)))

;; state monad
(defstruct (transited-result
	     (:constructor transited-result
			   (value state)))
  value
  state)

(defstruct (transition (:constructor transition (proc)))
  proc)
	   
(defmethod unit-m ((type (eql 'transition)) x)
  (transition
   (lambda (state) 
     (transited-result x state))))

(defmethod bind ((transition transition) proc-returning-transition)
  (transition
   (lambda (state)
     (let* ((first-transited-result 
	     (funcall (transition-proc transition) state))
	    (new-transition 
	     (funcall proc-returning-transition
		      (transited-result-value first-transited-result))))
       (funcall (transition-proc new-transition)
		(transited-result-state first-transited-result))))))


;; state-example
(defun transit-push (a)
  (transition
   (lambda (state)
     (transited-result nil (cons a state)))))

(defun transit-pop ()
  (transition
   (lambda (state)
     (transited-result (car state) (cdr state)))))

(setf 
 stack-12-to-21
 (do-monad 'transition
  (setm x (transit-pop))
  (setm y (transit-pop))
  (transit-push x)
  (transit-push y)))

 ;; parser 
(defstruct (parser (:constructor parser (proc)))
  proc)

(defun parse (parser text)
  (funcall (parser-proc parser) text))

(defstruct (parse-result (:constructor parse-result (value text)))
  value text)

(defstruct (failed-result (:constructor failed-result (msg)))
  msg)

(defmethod unit-m ((type (eql 'parser)) x) 
  (parser 
   (lambda (text)
     (parse-result x text))))

(defmethod bind ((parser parser) proc-returning-parser)
  (parser
   (lambda (text)
     (let ((parse-result 
	    (funcall (parser-proc parser) text)))
       (match parse-result
	 ((failed-result :msg _)
	  parse-result)
	 ((parse-result :value value :text text)
	  (let ((new-parser 
		 (funcall proc-returning-parser value)))
	    (funcall (parser-proc new-parser) text))))))))


(defun item ()
  (parser 
   (lambda (text)
     (if (string= text "")
	 (failed-result "getiing text error")
	 (parse-result (subseq text 0 1)
		       (subseq text 1 
			       (length text)))))))

(defun failure (msg)
  (parser (lambda (text)
	    (declare (ignore text))
	    (failed-result msg))))

(defun spaces ()
  (parser (lambda (text)
	    (parse-result nil (front-space-delete text)))))

(defun front-space-delete (text)
  (let ((result 
	 (position-if-not (lambda (s) (string= s " ")) text)))
    (if result
	(subseq text result (length text)) 
	"")))

(defun number ()
  (do-monad 'parser
    (setm c (item))
    (if (find c "1234567890" :test #'string=)
	(unit-m (parse-integer c))
	(failure "not number"))))

(defun eof ()
  (parser
   (lambda (text)
     (if (string= text "")
	 (parse-result nil "")
	 (failed-result "not end")))))

(defun plus ()
  (do-monad 'parser
    (setm c (item))
    (if (string= c "+")
	(unit-m t)
	(failure "not + at plus"))))

(defun my-parser1 ()
  (do-monad 'parser
    (spaces)
    (setm x (number))
    (spaces)
    (plus)
    (spaces)
    (setm y (number))
    (spaces)
    (unit-m (+ x y))))