[Cl-monad-macros-cvs] r1 - trunk
David Sorokin
dsorokin at common-lisp.net
Wed Jan 20 05:39:11 UTC 2010
Author: dsorokin
Date: Wed Jan 20 00:39:10 2010
New Revision: 1
Log:
Initial commit
Added:
trunk/
trunk/cl-monad-macros.asd
trunk/cl-monad-macros.lisp
Added: trunk/cl-monad-macros.asd
==============================================================================
--- (empty file)
+++ trunk/cl-monad-macros.asd Wed Jan 20 00:39:10 2010
@@ -0,0 +1,36 @@
+
+;;; 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-asd (:use :asdf :cl))
+
+(in-package :cl-monad-macros-asd)
+
+(defsystem :cl-monad-macros
+ :version "0.1"
+ :author "David Sorokin <david.sorokin at gmail.com>"
+ :description "Monad Macros for Common Lisp."
+ :components ((:file "cl-monad-macros")))
Added: trunk/cl-monad-macros.lisp
==============================================================================
--- (empty file)
+++ trunk/cl-monad-macros.lisp Wed Jan 20 00:39:10 2010
@@ -0,0 +1,813 @@
+
+;;; 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
+ :universal-let!
+ :universal-progn!
+ :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
+;;;
+
+(defmacro generic-progn! (funcall-func &body ms)
+ (reduce #'(lambda (m1 m2)
+ (let ((x (gensym)))
+ `(,funcall-func
+ #'(lambda (, x)
+ (declare (ignore ,x))
+ ,m2)
+ ,m1)))
+ ms
+ :from-end t))
+
+(defmacro 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) (append '(generic-progn!) '(,funcall-func) ms))
+ (let! (decls m) (list 'generic-let! ',funcall-func decls m)))
+ , at body))
+
+;;;
+;;; The Bind Macros
+;;;
+
+(defmacro universal-progn! (&body ms)
+ (reduce #'(lambda (m1 m2)
+ (let ((x (gensym)))
+ `(funcall!
+ #'(lambda (, x)
+ (declare (ignore ,x))
+ ,m2)
+ ,m1)))
+ ms
+ :from-end t))
+
+(defmacro universal-let! (decls m)
+ (reduce #'(lambda (decl m)
+ (destructuring-bind (x e) decl
+ `(funcall! #'(lambda (,x) ,m) ,e)))
+ decls
+ :from-end t
+ :initial-value m))
+
+;;;
+;;; 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)))
+ , at body))
+
+;;;
+;;; The List Monad
+;;;
+
+(defmacro list-progn! (&body ms)
+ (reduce #'(lambda (m1 m2)
+ (let ((x (gensym)))
+ `(loop for ,x in ,m1 append ,m2)))
+ ms
+ :from-end t))
+
+(defmacro 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) (append '(list-progn!) ms))
+ (let! (decls m) (list 'list-let! decls m)))
+ , at 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))
+
+(defmacro maybe-unit (a)
+ `(make-maybe :just ,a))
+
+(defmacro 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))))))
+
+(defmacro maybe-progn! (&body ms)
+ (reduce #'(lambda (m1 m2)
+ `(if (maybe-nil-p ,m1)
+ (make-maybe)
+ ,m2))
+ ms
+ :from-end t))
+
+(defmacro 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) (list 'maybe-unit a))
+ (funcall! (k m) (list 'maybe-funcall! k m))
+ (progn! (&body ms) (append '(maybe-progn!) ms))
+ (let! (decls m) (list 'maybe-let! decls m)))
+ , at body))
+
+;;;
+;;; The Reader Monad
+;;;
+
+(defmacro reader-unit (a)
+ (let ((r (gensym)))
+ `#'(lambda (,r)
+ (declare (ignore ,r))
+ ,a)))
+
+(defmacro 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)))))
+
+(defmacro 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))
+
+(defmacro reader-progn! (&body ms)
+ (reduce #'(lambda (m1 m2)
+ (let ((r (gensym)))
+ `#'(lambda (,r)
+ (funcall ,m1 ,r)
+ (funcall ,m2 ,r))))
+ ms
+ :from-end t))
+
+(defmacro reader-read! ()
+ (let ((r (gensym)))
+ `#'(lambda (,r) ,r)))
+
+(defmacro reader-run! (m r)
+ `(funcall ,m ,r))
+
+(defmacro with-reader-monad (&body body)
+ `(macrolet
+ ((unit (a) (list 'reader-unit a))
+ (funcall! (k m) (list 'reader-funcall! k m))
+ (progn! (&body ms) (append '(reader-progn!) ms))
+ (let! (decls m) (list 'reader-let! decls m))
+ (read! () (list 'reader-read!))
+ (run! (m r) (list 'reader-run! m r)))
+ , at body))
+
+;;;
+;;; The State Monad
+;;;
+
+(defmacro make-state (a st)
+ `(cons ,a ,st))
+
+(defmacro state-value (m)
+ `(car ,m))
+
+(defmacro state-state (m)
+ `(cdr ,m))
+
+(defmacro state-unit (a)
+ (let ((st (gensym)))
+ `#'(lambda (,st)
+ (make-state ,a ,st))))
+
+(defmacro 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))))))))
+
+(defmacro 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))
+
+(defmacro state-progn! (&body 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))
+
+(defmacro state-run! (m init-st)
+ (let ((p (gensym)))
+ `(let ((,p (funcall ,m ,init-st)))
+ (list (state-value ,p)
+ (state-state ,p)))))
+
+(defmacro state-get! ()
+ (let ((st (gensym)))
+ `#'(lambda (,st)
+ (make-state ,st ,st))))
+
+(defmacro 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) (list 'state-unit a))
+ (funcall! (k m) (list 'state-funcall! k m))
+ (progn! (&body ms) (append '(state-progn!) ms))
+ (let! (decls m) (list 'state-let! decls m))
+ (get! () (list 'state-get!))
+ (put! (new-st) (list 'state-put! new-st))
+ (run! (m init-st) (list 'state-run! m init-st)))
+ , at 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))))))))
+
+(defmacro writer-write! (&body 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 , at ws)))
+ #'(lambda (xs)
+ (append ,vs xs)))))))
+
+(defmacro writer-write-list! (&body 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 , at wss)))
+ #'(lambda (xs)
+ (reduce #'append ,vss
+ :from-end t
+ :initial-value xs)))))))
+
+(defmacro 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)))))))
+
+(defmacro writer-unit (a)
+ `(make-writer ,a nil))
+
+(defmacro 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))))))
+
+(defmacro 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))
+
+
+(defmacro writer-progn! (&body 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) (list 'writer-unit a))
+ (funcall! (k m) (list 'writer-funcall! k m))
+ (progn! (&body ms) (append '(writer-progn!) ms))
+ (let! (decls m) (list 'writer-let! decls m))
+ (write! (&body ws) (append '(writer-write!) ws))
+ (write-list! (&body wss) (append '(writer-write-list!) wss))
+ (run! (m) (list 'writer-run! m)))
+ , at 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)
+ (append '(with-inner-monad-prototype)
+ (list ',outer-monad)
+ (list ',inner-monad)
+ (list id)
+ bs))
+ (with-outer-monad-trans (id &body bs)
+ (append id bs))
+ ;;
+ (inner-unit (a) (list 'generic-inner-unit a))
+ (inner-funcall! (k m) (list 'generic-inner-funcall! k m))
+ (inner-progn! (&body ms) (append '(generic-inner-progn!) ms))
+ (inner-let! (decls m) (list 'generic-inner-let! decls m)))
+ , at body)))
+
+(defmacro with-inner-monad-prototype
+ (outer-monad inner-monad id &body body)
+ `(macrolet ((, at id (&body bs) (append ',outer-monad bs)))
+ (, at inner-monad
+ , at body)))
+
+(defmacro generic-inner-unit (a)
+ (let ((id (gensym)))
+ `(with-inner-monad-trans (,id)
+ (unit
+ (with-outer-monad-trans (,id)
+ ,a)))))
+
+(defmacro 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)))))
+
+(defmacro 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))
+
+(defmacro generic-inner-progn! (&body 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! , at outer-ms)))))
+
+;;;
+;;; The Reader Monad Transformer
+;;;
+
+(defmacro reader-trans-unit (a)
+ (let ((r (gensym)))
+ `#'(lambda (,r)
+ (declare (ignore ,r))
+ (inner-unit ,a))))
+
+(defmacro 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))))))
+
+(defmacro 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))
+
+(defmacro reader-trans-progn! (&body ms)
+ (reduce #'(lambda (m1 m2)
+ (let ((r (gensym)))
+ `#'(lambda (,r)
+ (inner-progn!
+ (funcall ,m1 ,r)
+ (funcall ,m2 ,r)))))
+ ms
+ :from-end t))
+
+(defmacro reader-trans-read! ()
+ (let ((r (gensym)))
+ `#'(lambda (,r)
+ (inner-unit ,r))))
+
+(defmacro reader-trans-run! (m r)
+ `(funcall ,m ,r))
+
+(defmacro 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) (list 'reader-trans-unit a))
+ (funcall! (k m) (list 'reader-trans-funcall! k m))
+ (progn! (&body ms) (append '(reader-trans-progn!) ms))
+ (let! (decls m) (list 'reader-trans-let! decls m))
+ (read! () (list 'reader-trans-read!))
+ (run! (m r) (list 'reader-trans-run! m r))
+ (lift! (m) (list 'reader-trans-lift! m)))
+ , at body)))
+
+;;;
+;;; The State Monad Transformer
+;;;
+
+(defmacro state-trans-unit (a)
+ (let ((st (gensym)))
+ `#'(lambda (,st)
+ (inner-unit
+ (make-state ,a ,st)))))
+
+(defmacro 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))))))))
+
+(defmacro 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))
+
+(defmacro state-trans-progn! (&body 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))
+
+(defmacro 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))))))
+
+(defmacro state-trans-get! ()
+ (let ((st (gensym)))
+ `#'(lambda (,st)
+ (inner-unit
+ (make-state ,st ,st)))))
+
+(defmacro state-trans-put! (new-st)
+ (let ((st (gensym)))
+ `#'(lambda (,st)
+ (declare (ignore ,st))
+ (inner-unit
+ (make-state nil ,new-st)))))
+
+(defmacro 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) (list 'state-trans-unit a))
+ (funcall! (k m) (list 'state-trans-funcall! k m))
+ (progn! (&body ms) (append '(state-trans-progn!) ms))
+ (let! (decls m) (list 'state-trans-let! decls m))
+ (get! () (list 'state-trans-get!))
+ (put! (new-st) (list 'state-trans-put! new-st))
+ (run! (m init-st) (list 'state-trans-run! m init-st))
+ (lift! (m) (list 'state-trans-lift! m)))
+ , at body)))
+
+;;;
+;;; The Writer Monad Transformer
+;;;
+
+(defmacro writer-trans-write! (&body 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 , at ws)))
+ #'(lambda (xs)
+ (append ,vs xs))))))))
+
+(defmacro writer-trans-write-list! (&body 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 , at wss)))
+ #'(lambda (xs)
+ (reduce #'append ,vss
+ :from-end t
+ :initial-value xs))))))))
+
+(defmacro 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))))))))
+
+(defmacro writer-trans-unit (a)
+ `(inner-unit
+ (make-writer ,a nil)))
+
+(defmacro 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))))))))))
+
+(defmacro 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))
+
+(defmacro writer-trans-progn! (&body 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))
+
+(defmacro 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) (list 'writer-trans-unit a))
+ (funcall! (k m) (list 'writer-trans-funcall! k m))
+ (progn! (&body ms) (append '(writer-trans-progn!) ms))
+ (let! (decls m) (list 'writer-trans-let! decls m))
+ (write! (&body ws) (append '(writer-trans-write!) ws))
+ (write-list! (&body wss) (append '(writer-trans-write-list!) wss))
+ (run! (m) (list 'writer-trans-run! m))
+ (lift! (m) (list 'writer-trans-lift! m)))
+ , at body)))
More information about the cl-monad-macros-cvs
mailing list