100 lines
4.4 KiB
Common Lisp
100 lines
4.4 KiB
Common Lisp
(defgeneric monadic-map (monad-class function))
|
|
|
|
(defgeneric monadic-join (monad-class container-of-containers &rest additional))
|
|
|
|
(defgeneric monadic-instance (monad-class-name))
|
|
|
|
(defmacro comprehend (monad-instance expr &rest clauses)
|
|
(let ((monad-var (gensym "CLASS-")))
|
|
(cond
|
|
((null clauses) `(multiple-value-call #'monadic-unit
|
|
,monad-instance ,expr))
|
|
((rest clauses) `(let ((,monad-var ,monad-instance))
|
|
(multiple-value-call #'monadic-join ,monad-var
|
|
(comprehend ,monad-var
|
|
(comprehend ,monad-var ,expr ,@(rest clauses))
|
|
,(first clauses)))))
|
|
(t (destructuring-bind (var &rest container-exprs) (first clauses)
|
|
(cond
|
|
((and var (symbolp var))
|
|
`(funcall (monadic-map ,monad-instance (lambda (,var) ,expr))
|
|
,(first container-exprs)))
|
|
((and (consp var) (every #'symbolp var))
|
|
`(multiple-value-call (monadic-map ,monad-instance
|
|
(lambda (,@var) ,expr))
|
|
,@container-exprs))
|
|
(t (error "COMPREHEND: bad variable specification: ~s" vars))))))))
|
|
|
|
(defmacro define-monad (class-name
|
|
&key comprehension
|
|
(monad-param (gensym "MONAD-"))
|
|
bases slots initargs
|
|
((:map ((map-param)
|
|
&body map-body)))
|
|
((:join ((join-param
|
|
&optional
|
|
(j-rest-kw '&rest)
|
|
(j-rest (gensym "JOIN-REST-")))
|
|
&body join-body)))
|
|
((:unit ((unit-param
|
|
&optional
|
|
(u-rest-kw '&rest)
|
|
(u-rest (gensym "UNIT-REST-")))
|
|
&body unit-body))))
|
|
`(progn
|
|
(defclass ,class-name ,bases ,slots)
|
|
(defmethod monadic-instance ((monad (eql ',class-name)))
|
|
(load-time-value (make-instance ',class-name ,@initargs)))
|
|
(defmethod monadic-map ((,monad-param ,class-name) ,map-param)
|
|
(declare (ignorable ,monad-param))
|
|
,@map-body)
|
|
(defmethod monadic-join ((,monad-param ,class-name)
|
|
,join-param &rest ,j-rest)
|
|
(declare (ignorable ,monad-param ,j-rest))
|
|
,@join-body)
|
|
(defmethod monadic-unit ((,monad-param ,class-name)
|
|
,unit-param &rest ,u-rest)
|
|
(declare (ignorable ,monad-param ,u-rest))
|
|
,@unit-body)
|
|
,@(if comprehension
|
|
`((defmacro ,comprehension (expr &rest clauses)
|
|
`(comprehend (monadic-instance ',',class-name)
|
|
,expr ,@clauses))))))
|
|
|
|
(defmethod monadic-map ((monad symbol) function)
|
|
(monadic-map (monadic-instance monad) function))
|
|
|
|
(defmethod monadic-join ((monad symbol) container-of-containers &rest rest)
|
|
(apply #'monadic-join (monadic-instance monad) container-of-containers rest))
|
|
|
|
(defmethod monadic-unit ((monad symbol) element &rest rest)
|
|
(apply #'monadic-unit (monadic-instance monad) element rest))
|
|
|
|
(define-monad list-monad
|
|
:comprehension list-comp
|
|
:map ((function) (lambda (container) (mapcar function container)))
|
|
:join ((list-of-lists) (reduce #'append list-of-lists))
|
|
:unit ((element) (list element)))
|
|
|
|
(define-monad identity-monad
|
|
:comprehension identity-comp
|
|
:map ((f) f)
|
|
:join ((x &rest rest) (apply #'values x rest))
|
|
:unit ((x &rest rest) (apply #'values x rest)))
|
|
|
|
(define-monad state-xform-monad
|
|
:comprehension state-xform-comp
|
|
:map ((f)
|
|
(lambda (xformer)
|
|
(lambda (s)
|
|
(identity-comp (values (funcall f x) new-state)
|
|
((x new-state) (funcall xformer s))))))
|
|
:join ((nested-xformer)
|
|
(lambda (s)
|
|
(identity-comp (values x new-state)
|
|
((embedded-xformer intermediate-state)
|
|
(funcall nested-xformer s))
|
|
((x new-state)
|
|
(funcall embedded-xformer intermediate-state)))))
|
|
:unit ((x) (lambda (s) (values x s))))
|