;;; This file defines the Monad Macros.

;;; Copyright (c) 2010, David Sorokin. All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.
;;;
;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(defpackage :cl-monad-macros
  (:use :common-lisp)
  (:export
   :with-monad
   :with-identity-monad
   :with-list-monad
   :with-maybe-monad
   :with-reader-monad
   :with-reader-monad-trans
   :with-writer-monad
   :with-writer-monad-trans
   :with-state-monad
   :with-state-monad-trans
   :with-monad-trans
   :with-inner-monad-trans
   :with-outer-monad-trans
   :unit
   :funcall!
   :let!
   :progn!
   :lift!
   :inner-unit
   :inner-funcall!
   :inner-let!
   :inner-progn!
   :make-maybe
   :maybe-just
   :maybe-just-p
   :maybe-nil
   :maybe-nil-p
   :run!
   :read!
   :write!
   :write-list!
   :get!
   :put!))

(in-package :cl-monad-macros)

;;;
;;; General Case
;;;

(defun generic-progn! (funcall-func ms)
  (reduce #'(lambda (m1 m2)
	      (let ((x (gensym)))
		`(,funcall-func 
		  #'(lambda (, x)
		      (declare (ignore ,x))
		      ,m2)
		  ,m1)))
	  ms
	  :from-end t))

(defun generic-let! (funcall-func decls m)
  (reduce #'(lambda (decl m)
	      (destructuring-bind (x e) decl
		`(,funcall-func #'(lambda (,x) ,m) ,e)))
	  decls
	  :from-end t
	  :initial-value m))
	      
(defmacro with-monad ((unit-func funcall-func) &body body)
  `(macrolet
       ((unit (a) (list ',unit-func a))
	(funcall! (k m) (list ',funcall-func k m))
	(progn! (&body ms) (generic-progn! ',funcall-func ms))
	(let! (decls m) (generic-let! ',funcall-func decls m)))
     ,@body))

;;;
;;; The Identity Monad
;;;

(defmacro with-identity-monad (&body body)
  `(macrolet
       ((unit (a) a)
	(funcall! (k m) (list 'funcall k m))
	(progn! (&body ms) (append '(progn) ms))
	(let! (decls m) (list 'let* decls m)))
     ,@body))

;;;
;;; The List Monad
;;;

(defun list-progn! (ms)
  (reduce #'(lambda (m1 m2)
	      (let ((x (gensym)))
		`(loop for ,x in ,m1 append ,m2)))
	  ms
	  :from-end t))

(defun list-let! (decls m)
  (reduce #'(lambda (decl m)
	      (destructuring-bind (x e) decl
		`(loop for ,x in ,e append ,m)))
	  decls
	  :from-end t
	  :initial-value m))
	      
(defmacro with-list-monad (&body body)
  `(macrolet
       ((unit (a) `(list ,a))
	(funcall! (k m) `(reduce #'append (mapcar ,k ,m)))
	(progn! (&body ms) (list-progn! ms))
	(let! (decls m) (list-let! decls m)))
     ,@body))

;;;
;;; The Maybe Monad
;;;

(defmacro make-maybe (&key (just nil just-supplied-p))
  (if just-supplied-p `(cons ,just nil)))

(defmacro maybe-just (a)
  `(car ,a))

(defmacro maybe-nil ()
  nil)

(defmacro maybe-just-p (m)
  `(consp ,m))

(defmacro maybe-nil-p (m)
  `(null ,m))

(defun maybe-unit (a)
  `(make-maybe :just ,a))

(defun maybe-funcall! (k m)
  (let ((xk (gensym))
	(xm (gensym)))
    `(let ((,xk ,k)
	   (,xm ,m))
       (if (maybe-nil-p ,xm)
	   (make-maybe)
	   (funcall ,xk (maybe-just ,xm))))))

(defun maybe-progn! (ms)
  (reduce #'(lambda (m1 m2)
	      `(if (maybe-nil-p ,m1)
		   (make-maybe)
		   ,m2))
	  ms
	  :from-end t))

(defun maybe-let! (decls m)
  (reduce #'(lambda (decl m)
	      (destructuring-bind (x e) decl
		(let ((xe (gensym)))
		  `(let ((,xe ,e))
		     (if (maybe-nil-p ,xe)
			 (make-maybe)
			 (let ((,x (maybe-just ,xe)))
			   ,m))))))
	  decls
	  :from-end t
	  :initial-value m))

(defmacro with-maybe-monad (&body body)
  `(macrolet
       ((unit (a) (maybe-unit a))
	(funcall! (k m) (maybe-funcall! k m))
	(progn! (&body ms) (maybe-progn! ms))
	(let! (decls m) (maybe-let! decls m)))
     ,@body))

;;;
;;; The Reader Monad
;;;

(defun reader-unit (a)
  (let ((r (gensym)))
    `#'(lambda (,r)
	 (declare (ignore ,r))
	 ,a)))

(defun reader-funcall! (k m)
  (let ((r (gensym))
	(a (gensym))
	(kg (gensym)))
    `#'(lambda (,r)
	 (let ((,kg ,k)
	       (,a (funcall ,m ,r)))
	   (funcall (funcall ,kg ,a) ,r)))))

(defun reader-let! (decls m)
  (reduce #'(lambda (decl m)
	      (destructuring-bind (x e) decl
		(let ((r (gensym)))
		  `#'(lambda (,r)
		       (let ((,x (funcall ,e ,r)))
			 (funcall ,m ,r))))))
	  decls
	  :from-end t
	  :initial-value m))

(defun reader-progn! (ms)
  (reduce #'(lambda (m1 m2)
	      (let ((r (gensym)))
		`#'(lambda (,r)
			 (funcall ,m1 ,r)
			 (funcall ,m2 ,r))))
	  ms
	  :from-end t))

(defun reader-read! ()
  (let ((r (gensym)))
    `#'(lambda (,r) ,r)))

(defun reader-run! (m r)
  `(funcall ,m ,r))

(defmacro with-reader-monad (&body body)
  `(macrolet
       ((unit (a) (reader-unit a))
	(funcall! (k m) (reader-funcall! k m))
	(progn! (&body ms) (reader-progn! ms))
	(let! (decls m) (reader-let! decls m))
	(read! () (reader-read!))
	(run! (m r) (reader-run! m r)))
     ,@body))

;;;
;;; The State Monad
;;;

(defmacro make-state (a st)
  `(cons ,a ,st))

(defmacro state-value (m)
  `(car ,m))

(defmacro state-state (m)
  `(cdr ,m))

(defun state-unit (a)
  (let ((st (gensym)))
    `#'(lambda (,st)
	 (make-state ,a ,st))))

(defun state-funcall! (k m)
  (let ((st (gensym))
	(p (gensym))
	(a (gensym))
	(kg (gensym)))
    `#'(lambda (,st)
	 (let ((,kg ,k))
	   (let ((,p (funcall ,m ,st)))
	     (let ((,a (state-value ,p)))
	       (funcall (funcall ,kg ,a)
			(state-state ,p))))))))

(defun state-let! (decls m)
  (reduce #'(lambda (decl m)
	      (destructuring-bind (x e) decl
		(let ((st (gensym))
		      (p (gensym)))
		  `#'(lambda (,st)
		       (let ((,p (funcall ,e ,st)))
			 (let ((,x (state-value ,p)))
			   (funcall ,m (state-state ,p))))))))
	  decls
	  :from-end t
	  :initial-value m))

(defun state-progn! (ms)
  (reduce #'(lambda (m1 m2)
	      (let ((st (gensym))
		    (p (gensym)))
		`#'(lambda (,st)
		     (let ((,p (funcall ,m1 ,st)))
		       (funcall ,m2 (state-state ,p))))))
	  ms
	  :from-end t))

(defun state-run! (m init-st)
  (let ((p (gensym)))
    `(let ((,p (funcall ,m ,init-st)))
       (list (state-value ,p)
	     (state-state ,p)))))

(defun state-get! ()
  (let ((st (gensym)))
    `#'(lambda (,st)
	 (make-state ,st ,st))))

(defun state-put! (new-st)
  (let ((st (gensym)))
    `#'(lambda (,st)
	 (declare (ignore ,st))
	 (make-state nil ,new-st))))

(defmacro with-state-monad (&body body)
  `(macrolet
       ((unit (a) (state-unit a))
	(funcall! (k m) (state-funcall! k m))
	(progn! (&body ms) (state-progn! ms))
	(let! (decls m) (state-let! decls m))
	(get! () (state-get!))
	(put! (new-st) (state-put! new-st))
	(run! (m init-st) (state-run! m init-st)))
     ,@body))

;;;
;;; The Writer Monad
;;;

(defmacro make-writer (a fun)
  `(cons ,a ,fun))

(defmacro writer-value (m)
  `(car ,m))

(defmacro writer-fun (m)
  `(cdr ,m))

(defmacro writer-compose (f g)
  ;; There are high chances that g is NIL
  (let ((fs (gensym))
	(gs (gensym)))
    `(let ((,fs ,f)
	   (,gs ,g))
       (cond ((null ,gs) ,fs)    ; check it first
	     ((null ,fs) ,gs)
	     (t #'(lambda (x)
		    (funcall ,fs
			     (funcall ,gs x))))))))

(defun writer-write! (ws)
    (if (= 1 (length ws))
	;; An optimized case
	(let ((w (nth 0 ws))
	      (v (gensym)))
	  `(make-writer nil
			(let ((,v ,w))
			  #'(lambda (xs) (cons ,v xs)))))
	;; A general case
	(let ((vs (gensym)))
	  `(make-writer nil
			(let ((,vs (list ,@ws)))
			  #'(lambda (xs)
			      (append ,vs xs)))))))

(defun writer-write-list! (wss)
    (if (= 1 (length wss))
	;; An optimized case
	(let ((ws (nth 0 wss))
	      (vs (gensym)))
	  `(make-writer nil
			(let ((,vs ,ws))
			  #'(lambda (xs) (append ,vs xs)))))
	;; A general case
	(let ((vss (gensym)))
	  `(make-writer nil
			(let ((,vss (list ,@wss)))
			  #'(lambda (xs)
			      (reduce #'append ,vss
				      :from-end t
				      :initial-value xs)))))))
			 
(defun writer-run! (m)
  (let ((x (gensym))
	(fun (gensym)))
    `(let ((,x ,m))
       (list (writer-value ,x)
	     (let ((,fun (writer-fun ,x)))
	       (if (not (null ,fun))
		   (funcall ,fun nil)))))))

(defun writer-unit (a)
  `(make-writer ,a nil))

(defun writer-funcall! (k m)
  (let ((ks (gensym))
	(ms (gensym))
	(a (gensym))
	(ka (gensym)))
    `(let* ((,ks ,k)    ; save it first
	    (,ms ,m)
	    (,a (writer-value ,ms))
	    (,ka (funcall ,ks ,a)))
       (make-writer (writer-value ,ka)
		    (writer-compose (writer-fun ,ms)
				    (writer-fun ,ka))))))

(defun writer-let! (decls m)
  (reduce 
   #'(lambda (decl m)
       (destructuring-bind (x e) decl
	 (let ((es (gensym))
	       (ms (gensym)))
	   `(let* ((,es ,e)
		   (,x (writer-value ,es))
		   (,ms ,m))    ; depends on x!
	      (make-writer (writer-value ,ms)
			   (writer-compose (writer-fun ,es)
					   (writer-fun ,ms)))))))
   decls
   :from-end t
   :initial-value m))
	

(defun writer-progn! (ms)
  (reduce 
   #'(lambda (m1 m2)
       (let ((m1s (gensym))
	     (m2s (gensym)))
	 `(let ((,m1s ,m1)
		(,m2s ,m2))
	    (make-writer (writer-value ,m2s)
			 (writer-compose (writer-fun ,m1s)
					 (writer-fun ,m2s))))))
   ms
   :from-end t))

(defmacro with-writer-monad (&body body)
  `(macrolet
       ((unit (a) (writer-unit a))
	(funcall! (k m) (writer-funcall! k m))
	(progn! (&body ms) (writer-progn! ms))
	(let! (decls m) (writer-let! decls m))
	(write! (&body ws) (writer-write! ws))
	(write-list! (&body wss) (writer-write-list! wss))
	(run! (m) (writer-run! m)))
     ,@body))

;;;
;;; The Monad Transformer
;;;

(defmacro with-monad-trans (outer-monad &body body)
  (let ((inner-monad (cadr outer-monad)))
    `(macrolet
	 ((with-inner-monad-trans (id &body bs)
	    (with-inner-monad-prototype
		    ',outer-monad
		    ',inner-monad
		    id
		    bs))
	  (with-outer-monad-trans (id &body bs)
	    (append id bs))
	  ;;
	  (inner-unit (a) (generic-inner-unit a))
	  (inner-funcall! (k m) (generic-inner-funcall! k m))
	  (inner-progn! (&body ms) (generic-inner-progn! ms))
	  (inner-let! (decls m) (generic-inner-let! decls m)))
       ,@body)))

(defun with-inner-monad-prototype (outer-monad inner-monad id body)
  `(macrolet ((,@id (&body bs) (append ',outer-monad bs)))
     (,@inner-monad
      ,@body)))

(defun generic-inner-unit (a)
  (let ((id (gensym)))
    `(with-inner-monad-trans (,id)
       (unit 
	(with-outer-monad-trans (,id)
	  ,a)))))

(defun generic-inner-funcall! (k m)
  (let ((id (gensym)))
    `(with-inner-monad-trans (,id)
       (funcall!
	(with-outer-monad-trans (,id) ,k)
	(with-outer-monad-trans (,id) ,m)))))

(defun generic-inner-let! (decls m)
  (reduce 
   #'(lambda (decl m)
       (destructuring-bind (x e) decl
	 (let ((id (gensym)))
	   `(with-inner-monad-trans (,id)
	      (let! ((,x (with-outer-monad-trans (,id) ,e)))
		    (with-outer-monad-trans (,id) ,m))))))
   decls
   :from-end t
   :initial-value m))
		    
(defun generic-inner-progn! (ms)
  (let ((id (gensym)))
    (let ((outer-ms (loop for m in ms collect
			 `(with-outer-monad-trans (,id) ,m))))
      `(with-inner-monad-trans (,id)
	 (progn! ,@outer-ms)))))

;;;
;;; The Reader Monad Transformer
;;;

(defun reader-trans-unit (a)
  (let ((r (gensym)))
    `#'(lambda (,r)
	 (declare (ignore ,r))
	 (inner-unit ,a))))

(defun reader-trans-funcall! (k m)
  (let ((r (gensym))
	(a (gensym))
	(kg (gensym)))
    `#'(lambda (,r)
	 (let ((,kg ,k))
	   (inner-let! ((,a (funcall ,m ,r)))
		       (funcall (funcall ,kg ,a) ,r))))))

(defun reader-trans-let! (decls m)
  (reduce #'(lambda (decl m)
	      (destructuring-bind (x e) decl
		(let ((r (gensym)))
		  `#'(lambda (,r)
		       (inner-let! ((,x (funcall ,e ,r)))
			 (funcall ,m ,r))))))
	  decls
	  :from-end t
	  :initial-value m))

(defun reader-trans-progn! (ms)
  (reduce #'(lambda (m1 m2)
	      (let ((r (gensym)))
		`#'(lambda (,r)
		     (inner-progn!
		      (funcall ,m1 ,r)
		      (funcall ,m2 ,r)))))
	  ms
	  :from-end t))

(defun reader-trans-read! ()
  (let ((r (gensym)))
    `#'(lambda (,r) 
	 (inner-unit ,r))))

(defun reader-trans-run! (m r)
  `(funcall ,m ,r))

(defun reader-trans-lift! (m)
  (let ((r (gensym)))
    `#'(lambda (,r) 
	 (declare (ignore ,r))
	 ,m)))

(defmacro with-reader-monad-trans (inner-monad &body body)
  `(with-monad-trans (with-reader-monad-trans ,inner-monad)
     (macrolet
	 ((unit (a) (reader-trans-unit a))
	  (funcall! (k m) (reader-trans-funcall! k m))
	  (progn! (&body ms) (reader-trans-progn! ms))
	  (let! (decls m) (reader-trans-let! decls m))
	  (read! () (reader-trans-read!))
	  (run! (m r) (reader-trans-run! m r))
	  (lift! (m) (reader-trans-lift! m)))
       ,@body)))

;;;
;;; The State Monad Transformer
;;;

(defun state-trans-unit (a)
  (let ((st (gensym)))
    `#'(lambda (,st)
	 (inner-unit
	  (make-state ,a ,st)))))

(defun state-trans-funcall! (k m)
  (let ((st (gensym))
	(p (gensym))
	(a (gensym))
	(kg (gensym)))
    `#'(lambda (,st)
	 (let ((,kg ,k))
	   (inner-let! ((,p (funcall ,m ,st)))
	     (let ((,a (state-value ,p)))
	       (funcall (funcall ,kg ,a)
			(state-state ,p))))))))

(defun state-trans-let! (decls m)
  (reduce #'(lambda (decl m)
	      (destructuring-bind (x e) decl
		(let ((st (gensym))
		      (p (gensym)))
		  `#'(lambda (,st)
		       (inner-let! ((,p (funcall ,e ,st)))
			 (let ((,x (state-value ,p)))
			   (funcall ,m (state-state ,p))))))))
	  decls
	  :from-end t
	  :initial-value m))

(defun state-trans-progn! (ms)
  (reduce #'(lambda (m1 m2)
	      (let ((st (gensym))
		    (p (gensym)))
		`#'(lambda (,st)
		     (inner-let! ((,p (funcall ,m1 ,st)))
		       (funcall ,m2 (state-state ,p))))))
	  ms
	  :from-end t))

(defun state-trans-run! (m init-st)
  (let ((p (gensym)))
    `(inner-let! ((,p (funcall ,m ,init-st)))
       (inner-unit
	(list (state-value ,p)
	      (state-state ,p))))))

(defun state-trans-get! ()
  (let ((st (gensym)))
    `#'(lambda (,st)
	 (inner-unit
	  (make-state ,st ,st)))))

(defun state-trans-put! (new-st)
  (let ((st (gensym)))
    `#'(lambda (,st)
	 (declare (ignore ,st))
	 (inner-unit
	  (make-state nil ,new-st)))))

(defun state-trans-lift! (m)
  (let ((st (gensym))
	(a (gensym)))
    `#'(lambda (,st) 
	 (inner-let! ((,a ,m))
	   (inner-unit
	    (make-state ,a ,st))))))

(defmacro with-state-monad-trans (inner-monad &body body)
  `(with-monad-trans (with-state-monad-trans ,inner-monad)
     (macrolet
	 ((unit (a) (state-trans-unit a))
	  (funcall! (k m) (state-trans-funcall! k m))
	  (progn! (&body ms) (state-trans-progn! ms))
	  (let! (decls m) (state-trans-let! decls m))
	  (get! () (state-trans-get!))
	  (put! (new-st) (state-trans-put! new-st))
	  (run! (m init-st) (state-trans-run! m init-st))
	  (lift! (m) (state-trans-lift! m)))
       ,@body)))

;;;
;;; The Writer Monad Transformer
;;;

(defun writer-trans-write! (ws)
    (if (= 1 (length ws))
	;; An optimized case
	(let ((w (nth 0 ws))
	      (v (gensym)))
	  `(inner-unit
	    (make-writer nil
			 (let ((,v ,w))
			   #'(lambda (xs) (cons ,v xs))))))
	;; A general case
	(let ((vs (gensym)))
	  `(inner-unit
	    (make-writer nil
			 (let ((,vs (list ,@ws)))
			   #'(lambda (xs)
			       (append ,vs xs))))))))

(defun writer-trans-write-list! (wss)
    (if (= 1 (length wss))
	;; An optimized case
	(let ((ws (nth 0 wss))
	      (vs (gensym)))
	  `(inner-unit
	    (make-writer nil
			 (let ((,vs ,ws))
			   #'(lambda (xs) (append ,vs xs))))))
	;; A general case
	(let ((vss (gensym)))
	  `(inner-unit
	    (make-writer nil
			 (let ((,vss (list ,@wss)))
			   #'(lambda (xs)
			       (reduce #'append ,vss
				       :from-end t
				       :initial-value xs))))))))

(defun writer-trans-run! (m)
  (let ((x (gensym))
	(fun (gensym)))
    `(inner-let! ((,x ,m))
		 (inner-unit
		  (list (writer-value ,x)
			(let ((,fun (writer-fun ,x)))
			  (if (not (null ,fun))
			      (funcall ,fun nil))))))))

(defun writer-trans-unit (a)
  `(inner-unit
    (make-writer ,a nil)))

(defun writer-trans-funcall! (k m)
  (let ((ks (gensym))
	(ms (gensym))
	(a (gensym))
	(ka (gensym)))
    `(let ((,ks ,k))
       (inner-let! ((,ms ,m))
	 (let ((,a (writer-value ,ms)))
	   (inner-let! ((,ka (funcall ,ks ,a)))
	     (inner-unit  
	      (make-writer (writer-value ,ka)
			   (writer-compose (writer-fun ,ms)
					   (writer-fun ,ka))))))))))

(defun writer-trans-let! (decls m)
  (reduce 
   #'(lambda (decl m)
       (destructuring-bind (x e) decl
	 (let ((es (gensym))
	       (ms (gensym)))
	   `(inner-let! ((,es ,e))
	      (let ((,x (writer-value ,es)))
		(inner-let! ((,ms ,m))
		  (inner-unit
		   (make-writer (writer-value ,ms)
				(writer-compose (writer-fun ,es)
						(writer-fun ,ms))))))))))
   decls
   :from-end t
   :initial-value m))

(defun writer-trans-progn! (ms)
  (reduce 
   #'(lambda (m1 m2)
       (let ((m1s (gensym))
	     (m2s (gensym)))
	 `(inner-let! ((,m1s ,m1)
		       (,m2s ,m2))
            (inner-unit
	     (make-writer (writer-value ,m2s)
			  (writer-compose (writer-fun ,m1s)
					  (writer-fun ,m2s)))))))
   ms
   :from-end t))

(defun writer-trans-lift! (m)
  (let ((a (gensym)))
    `(inner-let! ((,a ,m))
       (inner-unit
	(make-writer ,a nil)))))

(defmacro with-writer-monad-trans (inner-monad &body body)
  `(with-monad-trans (with-writer-monad-trans ,inner-monad)
     (macrolet
	 ((unit (a) (writer-trans-unit a))
	  (funcall! (k m) (writer-trans-funcall! k m))
	  (progn! (&body ms) (writer-trans-progn! ms))
	  (let! (decls m) (writer-trans-let! decls m))
	  (write! (&body ws) (writer-trans-write! ws))
	  (write-list! (&body wss) (writer-trans-write-list! wss))
	  (run! (m) (writer-trans-run! m))
	  (lift! (m) (writer-trans-lift! m)))
       ,@body)))