path: root/monads.lisp

;;;
;;; 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)
  (apply #'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.
;;;
;;; Example:
;;;
;;;   (let ((transformer (state-xform-comp (list x y z)
;;;                        (x (lambda (state)
;;;                             (values `(:stage x ,state) (1+ state))))
;;;                        (y (lambda (state)
;;;                             (values `(:stage y ,state) (+ 10 state))))
;;;                        (z (lambda (state)
;;;                             (values `(:stage z ,state) nil))))))
;;;     (funcall transformer 42))
;;;
;;;   -> ((:STAGE X 42) (:STAGE Y 43) (:STAGE Z 53))
;;;
(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))))