Skip to content

Instantly share code, notes, and snippets.

@NobukazuHanada
Created November 3, 2013 15:39
Show Gist options
  • Save NobukazuHanada/7291546 to your computer and use it in GitHub Desktop.
Save NobukazuHanada/7291546 to your computer and use it in GitHub Desktop.
さっきまでなんとなく、気がついたら書いていた。
(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))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment