Adding monads stuff from 2008.

1 files changed, 251 insertions, 0 deletions

diff --git a/monads.lisp b/monads.lisp
new file mode 100644
index 0000000..dcc82e6
--- /dev/null
+++ b/monads.lisp
@@ -0,0 +1,251 @@
+;;;
+;;; Common Lisp monads based on "Comprehending Monads" 
+;;; paper (Philip Wadler, 1990).
+;;; Kaz Kylheku <kkylheku@gmail.com>
+;;; November 2008
+;;;
+
+;;;
+;;; A monad is represented by a representative instance of its CLOS class.
+;;; There basic generic functions must be specialized for the class:
+;;; MONADIC-MAP, MONADIC-JOIN, and MONADIC-UNIT.
+;;;
+;;; The programmer should also implement a method called MONADIC-INSTANCE
+;;; which is specialized on the class name (via EQL method specialization).
+;;; This should instantiate and return a representative instance.
+;;;
+
+;;;
+;;; MONADIC-MAP
+;;;
+;;; Takes a function and returns a function. The input
+;;; function is of the form:
+;;;
+;;;  (lambda (input-element) ...) -> output-element
+;;;
+;;; MONADIC-MAP takes this function, and returns
+;;; a new function based on it, which is of this form:
+;;;
+;;;  (lambda (input-monadic-container) ...) -> output-monadic-container
+;;;
+;;; Conceptually, the monadic container is some containing type based
+;;; on the elements, and the functionn returned by MONADIC-MAP
+;;; cracks open the container, works with the elements, and then re-packages
+;;; the results as a container. In the case of LIST monads (provided below),
+;;; the monadic container type is literally a list of elements, and the
+;;; function that is returned by MONADIC-MAP performs a Lisp MAPCAR on one
+;;; container to produce a new container, using FUNCTION.
+;;;
+;;; Example:
+;;;
+;;;  (funcall (monadic-map 'list-monad (lambda (x) (* 10 x))) '(1 2 3))
+;;; 
+;;;  -> (10 20 30)
+;;;
+(defgeneric monadic-map (monad-class function))
+
+;;;
+;;; MONADIC-JOIN
+;;;
+;;; Conceptually, takes a monadic container-of-containers-of-elements, and
+;;; flattens it to a container of elements.  The LIST specialization
+;;; does this:
+;;;
+;;;  (monadic-join 'list-monad '((1 2 3) (4 5 6))) -> (1 2 3 4 5 6)
+;;;
+;;; The purpose of the &REST parameters is to support the notion of elements
+;;; that are multiple values. See comment for MONADIC-UNIT below.
+;;;  
+(defgeneric monadic-join (monad-class container-of-containers &rest additional))
+
+;;;
+;;; MONADIC-UNIT
+;;;
+;;; Takes a single element and produces a monadic container of that element.
+;;;
+;;; For lists, it makes a one-element list
+;;;
+;;;  (monadic-unit 'list-monad 1) -> (1)
+;;;
+;;; The purpose of the &REST parameters is to support elements which
+;;; are multiple values.  This is of particular importance in the identity
+;;; monad. The identity monad's unit function is variadic and returns all
+;;; of the parameters as multiple values. This works in conjunction with
+;;; the comprehension macro, allowing multiple value bindings, e.g:
+;;;
+;;;   (identity-comp (values x y) ((x y) (values 1 2)))
+;;;
+;;; Here (x y) get bound as if by (multiple-value-bind (x y) (values 1 2)).
+;;; Because the expression is  (values x y), the comprehension as a whole
+;;; returns 1 2 as a pair of values.
+;;;
+;;; Multiple value support is required in the identity monad, because
+;;; Wadler's paper expresses identity monads that bind multiple values.
+;;; Wadler's state transformer monad is based on a domain of state
+;;; transformer functions which return multiple values, and he uses
+;;; identity comprehensions to express the bodies of the operations,
+;;; where pairs of values coming from calls state transformers are
+;;; captured by two variables. I didn't want to represent that 
+;;; as (for instance) conses, but proper Lisp multiple values.
+;;;
+(defgeneric monadic-unit (monad-class element &rest additional))
+
+;;;
+;;; MONADIC-INSTANCE
+;;;
+;;; Should be specialized to symbol, and return an instance of that
+;;; class, preferrably the same instance every time, e.g. using
+;;; LOAD-TIME-VALUE.
+;;;
+;;;   ;; Fetch representative instance of foo-monad 
+;;;
+;;;   (defmethod monadic-instance ((monad-class-name (eql 'foo-monad)))
+;;;     (load-time-value (make-instance 'foo-monad)))
+;;;
+(defgeneric monadic-instance (monad-class-name))
+
+;;;
+;;; COMPREHEND
+;;;
+;;; Monadic comprehension, reducing to list comprehension for LIST monads.
+;;; Examples:
+;;;
+;;;  (comprehend 'list-monad 1) -> (1)
+;;;
+;;;  ;; collect X, for X in '(1 2 3)
+;;;  (comprehend 'list-monad x (x '(1 2 3))) -> (1 2 3) 
+;;;
+;;;  ;; collect (CONS X Y) for X in '(1 2 3) and Y in '(A B C).
+;;;  (comprehend 'list-monad (cons x y) (x '(1 2 3)) (y '(A B C)))
+;;;  -> ((1 . A) (1 . B) (1 . C) 
+;;;      (2 . A) (2 . B) (2 . C) 
+;;;      (3 . A) (3 . B) (3 . C))
+;;;
+;;; NOTE: the LIST-MONAD defines a convenience macro called LIST-COMP,
+;;; allowing (list-comp 1) -> (1) et cetera.
+;;;
+(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))))))))
+
+;;;
+;;; DEFINE-MONAD
+;;;
+;;; Monad-defining convenience macro. Defines a CLOS class for the monad,
+;;; with all three required methods specialized for that class, using
+;;; destructured keyword arguments.
+;;;
+;;; Base classes and slots for the class can be specified, as well
+;;; as a list of arguments for the MAKE-INSTANCE call.
+;;;
+;;; A method called MONADIC-INSTANCE is generated which is specialized
+;;; to the class name via an EQL specializer. It returns a representative
+;;; instance of the monad class which is used for the monad dispatch.
+;;;
+(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))))))
+
+;;;
+;;; Monad methods that handle symbolically named monads
+;;; by redirecting to the representative instance, similarly to how 
+;;; (make-instance 'sym ...) redirects to (make-instance (find-class 'sym) ...)
+;;; We don't resolve the monad symbol to its class, but rather
+;;; to the representative instance.
+;;;
+
+(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)
+  (appy #'monadic-unit (monadic-instance monad) element rest))
+
+;;;
+;;; Define the LIST-MONAD, succinctly
+;;;
+(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 the IDENTITY-MONAD.
+;;;
+(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)))
+
+;;;
+;;; State transformer monad, with operations expressed using comprehensions 
+;;; over the identity monad, featuring multiple-value binding.
+;;;
+(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))))