/[cl-monad-macros]/trunk/cl-monad-macros.lisp
ViewVC logotype

Contents of /trunk/cl-monad-macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 7 - (show annotations)
Wed Jan 27 17:59:48 2010 UTC (4 years, 2 months ago) by dsorokin
File size: 18547 byte(s)
Removed macros UNIVERSAL-LET! and UNIVERSAL-PROGN!.
1
2 ;;; This file defines the Monad Macros.
3
4 ;;; Copyright (c) 2010, David Sorokin. All rights reserved.
5 ;;;
6 ;;; Redistribution and use in source and binary forms, with or without
7 ;;; modification, are permitted provided that the following conditions
8 ;;; are met:
9 ;;;
10 ;;; * Redistributions of source code must retain the above copyright
11 ;;; notice, this list of conditions and the following disclaimer.
12 ;;;
13 ;;; * Redistributions in binary form must reproduce the above
14 ;;; copyright notice, this list of conditions and the following
15 ;;; disclaimer in the documentation and/or other materials
16 ;;; provided with the distribution.
17 ;;;
18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
21 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29
30 (defpackage :cl-monad-macros
31 (:use :common-lisp)
32 (:export
33 :with-monad
34 :with-identity-monad
35 :with-list-monad
36 :with-maybe-monad
37 :with-reader-monad
38 :with-reader-monad-trans
39 :with-writer-monad
40 :with-writer-monad-trans
41 :with-state-monad
42 :with-state-monad-trans
43 :with-monad-trans
44 :with-inner-monad-trans
45 :with-outer-monad-trans
46 :unit
47 :funcall!
48 :let!
49 :progn!
50 :lift!
51 :inner-unit
52 :inner-funcall!
53 :inner-let!
54 :inner-progn!
55 :make-maybe
56 :maybe-just
57 :maybe-just-p
58 :maybe-nil
59 :maybe-nil-p
60 :run!
61 :read!
62 :write!
63 :write-list!
64 :get!
65 :put!))
66
67 (in-package :cl-monad-macros)
68
69 ;;;
70 ;;; General Case
71 ;;;
72
73 (defun generic-progn! (funcall-func ms)
74 (reduce #'(lambda (m1 m2)
75 (let ((x (gensym)))
76 `(,funcall-func
77 #'(lambda (, x)
78 (declare (ignore ,x))
79 ,m2)
80 ,m1)))
81 ms
82 :from-end t))
83
84 (defun generic-let! (funcall-func decls m)
85 (reduce #'(lambda (decl m)
86 (destructuring-bind (x e) decl
87 `(,funcall-func #'(lambda (,x) ,m) ,e)))
88 decls
89 :from-end t
90 :initial-value m))
91
92 (defmacro with-monad ((unit-func funcall-func) &body body)
93 `(macrolet
94 ((unit (a) (list ',unit-func a))
95 (funcall! (k m) (list ',funcall-func k m))
96 (progn! (&body ms) (generic-progn! ',funcall-func ms))
97 (let! (decls m) (generic-let! ',funcall-func decls m)))
98 ,@body))
99
100 ;;;
101 ;;; The Identity Monad
102 ;;;
103
104 (defmacro with-identity-monad (&body body)
105 `(macrolet
106 ((unit (a) a)
107 (funcall! (k m) (list 'funcall k m))
108 (progn! (&body ms) (append '(progn) ms))
109 (let! (decls m) (list 'let* decls m)))
110 ,@body))
111
112 ;;;
113 ;;; The List Monad
114 ;;;
115
116 (defun list-progn! (ms)
117 (reduce #'(lambda (m1 m2)
118 (let ((x (gensym)))
119 `(loop for ,x in ,m1 append ,m2)))
120 ms
121 :from-end t))
122
123 (defun list-let! (decls m)
124 (reduce #'(lambda (decl m)
125 (destructuring-bind (x e) decl
126 `(loop for ,x in ,e append ,m)))
127 decls
128 :from-end t
129 :initial-value m))
130
131 (defmacro with-list-monad (&body body)
132 `(macrolet
133 ((unit (a) `(list ,a))
134 (funcall! (k m) `(reduce #'append (mapcar ,k ,m)))
135 (progn! (&body ms) (list-progn! ms))
136 (let! (decls m) (list-let! decls m)))
137 ,@body))
138
139 ;;;
140 ;;; The Maybe Monad
141 ;;;
142
143 (defmacro make-maybe (&key (just nil just-supplied-p))
144 (if just-supplied-p `(cons ,just nil)))
145
146 (defmacro maybe-just (a)
147 `(car ,a))
148
149 (defmacro maybe-nil ()
150 nil)
151
152 (defmacro maybe-just-p (m)
153 `(consp ,m))
154
155 (defmacro maybe-nil-p (m)
156 `(null ,m))
157
158 (defun maybe-unit (a)
159 `(make-maybe :just ,a))
160
161 (defun maybe-funcall! (k m)
162 (let ((xk (gensym))
163 (xm (gensym)))
164 `(let ((,xk ,k)
165 (,xm ,m))
166 (if (maybe-nil-p ,xm)
167 (make-maybe)
168 (funcall ,xk (maybe-just ,xm))))))
169
170 (defun maybe-progn! (ms)
171 (reduce #'(lambda (m1 m2)
172 `(if (maybe-nil-p ,m1)
173 (make-maybe)
174 ,m2))
175 ms
176 :from-end t))
177
178 (defun maybe-let! (decls m)
179 (reduce #'(lambda (decl m)
180 (destructuring-bind (x e) decl
181 (let ((xe (gensym)))
182 `(let ((,xe ,e))
183 (if (maybe-nil-p ,xe)
184 (make-maybe)
185 (let ((,x (maybe-just ,xe)))
186 ,m))))))
187 decls
188 :from-end t
189 :initial-value m))
190
191 (defmacro with-maybe-monad (&body body)
192 `(macrolet
193 ((unit (a) (maybe-unit a))
194 (funcall! (k m) (maybe-funcall! k m))
195 (progn! (&body ms) (maybe-progn! ms))
196 (let! (decls m) (maybe-let! decls m)))
197 ,@body))
198
199 ;;;
200 ;;; The Reader Monad
201 ;;;
202
203 (defun reader-unit (a)
204 (let ((r (gensym)))
205 `#'(lambda (,r)
206 (declare (ignore ,r))
207 ,a)))
208
209 (defun reader-funcall! (k m)
210 (let ((r (gensym))
211 (a (gensym))
212 (kg (gensym)))
213 `#'(lambda (,r)
214 (let ((,kg ,k)
215 (,a (funcall ,m ,r)))
216 (funcall (funcall ,kg ,a) ,r)))))
217
218 (defun reader-let! (decls m)
219 (reduce #'(lambda (decl m)
220 (destructuring-bind (x e) decl
221 (let ((r (gensym)))
222 `#'(lambda (,r)
223 (let ((,x (funcall ,e ,r)))
224 (funcall ,m ,r))))))
225 decls
226 :from-end t
227 :initial-value m))
228
229 (defun reader-progn! (ms)
230 (reduce #'(lambda (m1 m2)
231 (let ((r (gensym)))
232 `#'(lambda (,r)
233 (funcall ,m1 ,r)
234 (funcall ,m2 ,r))))
235 ms
236 :from-end t))
237
238 (defun reader-read! ()
239 (let ((r (gensym)))
240 `#'(lambda (,r) ,r)))
241
242 (defun reader-run! (m r)
243 `(funcall ,m ,r))
244
245 (defmacro with-reader-monad (&body body)
246 `(macrolet
247 ((unit (a) (reader-unit a))
248 (funcall! (k m) (reader-funcall! k m))
249 (progn! (&body ms) (reader-progn! ms))
250 (let! (decls m) (reader-let! decls m))
251 (read! () (reader-read!))
252 (run! (m r) (reader-run! m r)))
253 ,@body))
254
255 ;;;
256 ;;; The State Monad
257 ;;;
258
259 (defmacro make-state (a st)
260 `(cons ,a ,st))
261
262 (defmacro state-value (m)
263 `(car ,m))
264
265 (defmacro state-state (m)
266 `(cdr ,m))
267
268 (defun state-unit (a)
269 (let ((st (gensym)))
270 `#'(lambda (,st)
271 (make-state ,a ,st))))
272
273 (defun state-funcall! (k m)
274 (let ((st (gensym))
275 (p (gensym))
276 (a (gensym))
277 (kg (gensym)))
278 `#'(lambda (,st)
279 (let ((,kg ,k))
280 (let ((,p (funcall ,m ,st)))
281 (let ((,a (state-value ,p)))
282 (funcall (funcall ,kg ,a)
283 (state-state ,p))))))))
284
285 (defun state-let! (decls m)
286 (reduce #'(lambda (decl m)
287 (destructuring-bind (x e) decl
288 (let ((st (gensym))
289 (p (gensym)))
290 `#'(lambda (,st)
291 (let ((,p (funcall ,e ,st)))
292 (let ((,x (state-value ,p)))
293 (funcall ,m (state-state ,p))))))))
294 decls
295 :from-end t
296 :initial-value m))
297
298 (defun state-progn! (ms)
299 (reduce #'(lambda (m1 m2)
300 (let ((st (gensym))
301 (p (gensym)))
302 `#'(lambda (,st)
303 (let ((,p (funcall ,m1 ,st)))
304 (funcall ,m2 (state-state ,p))))))
305 ms
306 :from-end t))
307
308 (defun state-run! (m init-st)
309 (let ((p (gensym)))
310 `(let ((,p (funcall ,m ,init-st)))
311 (list (state-value ,p)
312 (state-state ,p)))))
313
314 (defun state-get! ()
315 (let ((st (gensym)))
316 `#'(lambda (,st)
317 (make-state ,st ,st))))
318
319 (defun state-put! (new-st)
320 (let ((st (gensym)))
321 `#'(lambda (,st)
322 (declare (ignore ,st))
323 (make-state nil ,new-st))))
324
325 (defmacro with-state-monad (&body body)
326 `(macrolet
327 ((unit (a) (state-unit a))
328 (funcall! (k m) (state-funcall! k m))
329 (progn! (&body ms) (state-progn! ms))
330 (let! (decls m) (state-let! decls m))
331 (get! () (state-get!))
332 (put! (new-st) (state-put! new-st))
333 (run! (m init-st) (state-run! m init-st)))
334 ,@body))
335
336 ;;;
337 ;;; The Writer Monad
338 ;;;
339
340 (defmacro make-writer (a fun)
341 `(cons ,a ,fun))
342
343 (defmacro writer-value (m)
344 `(car ,m))
345
346 (defmacro writer-fun (m)
347 `(cdr ,m))
348
349 (defmacro writer-compose (f g)
350 ;; There are high chances that g is NIL
351 (let ((fs (gensym))
352 (gs (gensym)))
353 `(let ((,fs ,f)
354 (,gs ,g))
355 (cond ((null ,gs) ,fs) ; check it first
356 ((null ,fs) ,gs)
357 (t #'(lambda (x)
358 (funcall ,fs
359 (funcall ,gs x))))))))
360
361 (defun writer-write! (ws)
362 (if (= 1 (length ws))
363 ;; An optimized case
364 (let ((w (nth 0 ws))
365 (v (gensym)))
366 `(make-writer nil
367 (let ((,v ,w))
368 #'(lambda (xs) (cons ,v xs)))))
369 ;; A general case
370 (let ((vs (gensym)))
371 `(make-writer nil
372 (let ((,vs (list ,@ws)))
373 #'(lambda (xs)
374 (append ,vs xs)))))))
375
376 (defun writer-write-list! (wss)
377 (if (= 1 (length wss))
378 ;; An optimized case
379 (let ((ws (nth 0 wss))
380 (vs (gensym)))
381 `(make-writer nil
382 (let ((,vs ,ws))
383 #'(lambda (xs) (append ,vs xs)))))
384 ;; A general case
385 (let ((vss (gensym)))
386 `(make-writer nil
387 (let ((,vss (list ,@wss)))
388 #'(lambda (xs)
389 (reduce #'append ,vss
390 :from-end t
391 :initial-value xs)))))))
392
393 (defun writer-run! (m)
394 (let ((x (gensym))
395 (fun (gensym)))
396 `(let ((,x ,m))
397 (list (writer-value ,x)
398 (let ((,fun (writer-fun ,x)))
399 (if (not (null ,fun))
400 (funcall ,fun nil)))))))
401
402 (defun writer-unit (a)
403 `(make-writer ,a nil))
404
405 (defun writer-funcall! (k m)
406 (let ((ks (gensym))
407 (ms (gensym))
408 (a (gensym))
409 (ka (gensym)))
410 `(let* ((,ks ,k) ; save it first
411 (,ms ,m)
412 (,a (writer-value ,ms))
413 (,ka (funcall ,ks ,a)))
414 (make-writer (writer-value ,ka)
415 (writer-compose (writer-fun ,ms)
416 (writer-fun ,ka))))))
417
418 (defun writer-let! (decls m)
419 (reduce
420 #'(lambda (decl m)
421 (destructuring-bind (x e) decl
422 (let ((es (gensym))
423 (ms (gensym)))
424 `(let* ((,es ,e)
425 (,x (writer-value ,es))
426 (,ms ,m)) ; depends on x!
427 (make-writer (writer-value ,ms)
428 (writer-compose (writer-fun ,es)
429 (writer-fun ,ms)))))))
430 decls
431 :from-end t
432 :initial-value m))
433
434
435 (defun writer-progn! (ms)
436 (reduce
437 #'(lambda (m1 m2)
438 (let ((m1s (gensym))
439 (m2s (gensym)))
440 `(let ((,m1s ,m1)
441 (,m2s ,m2))
442 (make-writer (writer-value ,m2s)
443 (writer-compose (writer-fun ,m1s)
444 (writer-fun ,m2s))))))
445 ms
446 :from-end t))
447
448 (defmacro with-writer-monad (&body body)
449 `(macrolet
450 ((unit (a) (writer-unit a))
451 (funcall! (k m) (writer-funcall! k m))
452 (progn! (&body ms) (writer-progn! ms))
453 (let! (decls m) (writer-let! decls m))
454 (write! (&body ws) (writer-write! ws))
455 (write-list! (&body wss) (writer-write-list! wss))
456 (run! (m) (writer-run! m)))
457 ,@body))
458
459 ;;;
460 ;;; The Monad Transformer
461 ;;;
462
463 (defmacro with-monad-trans (outer-monad &body body)
464 (let ((inner-monad (cadr outer-monad)))
465 `(macrolet
466 ((with-inner-monad-trans (id &body bs)
467 (with-inner-monad-prototype
468 ',outer-monad
469 ',inner-monad
470 id
471 bs))
472 (with-outer-monad-trans (id &body bs)
473 (append id bs))
474 ;;
475 (inner-unit (a) (generic-inner-unit a))
476 (inner-funcall! (k m) (generic-inner-funcall! k m))
477 (inner-progn! (&body ms) (generic-inner-progn! ms))
478 (inner-let! (decls m) (generic-inner-let! decls m)))
479 ,@body)))
480
481 (defun with-inner-monad-prototype (outer-monad inner-monad id body)
482 `(macrolet ((,@id (&body bs) (append ',outer-monad bs)))
483 (,@inner-monad
484 ,@body)))
485
486 (defun generic-inner-unit (a)
487 (let ((id (gensym)))
488 `(with-inner-monad-trans (,id)
489 (unit
490 (with-outer-monad-trans (,id)
491 ,a)))))
492
493 (defun generic-inner-funcall! (k m)
494 (let ((id (gensym)))
495 `(with-inner-monad-trans (,id)
496 (funcall!
497 (with-outer-monad-trans (,id) ,k)
498 (with-outer-monad-trans (,id) ,m)))))
499
500 (defun generic-inner-let! (decls m)
501 (reduce
502 #'(lambda (decl m)
503 (destructuring-bind (x e) decl
504 (let ((id (gensym)))
505 `(with-inner-monad-trans (,id)
506 (let! ((,x (with-outer-monad-trans (,id) ,e)))
507 (with-outer-monad-trans (,id) ,m))))))
508 decls
509 :from-end t
510 :initial-value m))
511
512 (defun generic-inner-progn! (ms)
513 (let ((id (gensym)))
514 (let ((outer-ms (loop for m in ms collect
515 `(with-outer-monad-trans (,id) ,m))))
516 `(with-inner-monad-trans (,id)
517 (progn! ,@outer-ms)))))
518
519 ;;;
520 ;;; The Reader Monad Transformer
521 ;;;
522
523 (defun reader-trans-unit (a)
524 (let ((r (gensym)))
525 `#'(lambda (,r)
526 (declare (ignore ,r))
527 (inner-unit ,a))))
528
529 (defun reader-trans-funcall! (k m)
530 (let ((r (gensym))
531 (a (gensym))
532 (kg (gensym)))
533 `#'(lambda (,r)
534 (let ((,kg ,k))
535 (inner-let! ((,a (funcall ,m ,r)))
536 (funcall (funcall ,kg ,a) ,r))))))
537
538 (defun reader-trans-let! (decls m)
539 (reduce #'(lambda (decl m)
540 (destructuring-bind (x e) decl
541 (let ((r (gensym)))
542 `#'(lambda (,r)
543 (inner-let! ((,x (funcall ,e ,r)))
544 (funcall ,m ,r))))))
545 decls
546 :from-end t
547 :initial-value m))
548
549 (defun reader-trans-progn! (ms)
550 (reduce #'(lambda (m1 m2)
551 (let ((r (gensym)))
552 `#'(lambda (,r)
553 (inner-progn!
554 (funcall ,m1 ,r)
555 (funcall ,m2 ,r)))))
556 ms
557 :from-end t))
558
559 (defun reader-trans-read! ()
560 (let ((r (gensym)))
561 `#'(lambda (,r)
562 (inner-unit ,r))))
563
564 (defun reader-trans-run! (m r)
565 `(funcall ,m ,r))
566
567 (defun reader-trans-lift! (m)
568 (let ((r (gensym)))
569 `#'(lambda (,r)
570 (declare (ignore ,r))
571 ,m)))
572
573 (defmacro with-reader-monad-trans (inner-monad &body body)
574 `(with-monad-trans (with-reader-monad-trans ,inner-monad)
575 (macrolet
576 ((unit (a) (reader-trans-unit a))
577 (funcall! (k m) (reader-trans-funcall! k m))
578 (progn! (&body ms) (reader-trans-progn! ms))
579 (let! (decls m) (reader-trans-let! decls m))
580 (read! () (reader-trans-read!))
581 (run! (m r) (reader-trans-run! m r))
582 (lift! (m) (reader-trans-lift! m)))
583 ,@body)))
584
585 ;;;
586 ;;; The State Monad Transformer
587 ;;;
588
589 (defun state-trans-unit (a)
590 (let ((st (gensym)))
591 `#'(lambda (,st)
592 (inner-unit
593 (make-state ,a ,st)))))
594
595 (defun state-trans-funcall! (k m)
596 (let ((st (gensym))
597 (p (gensym))
598 (a (gensym))
599 (kg (gensym)))
600 `#'(lambda (,st)
601 (let ((,kg ,k))
602 (inner-let! ((,p (funcall ,m ,st)))
603 (let ((,a (state-value ,p)))
604 (funcall (funcall ,kg ,a)
605 (state-state ,p))))))))
606
607 (defun state-trans-let! (decls m)
608 (reduce #'(lambda (decl m)
609 (destructuring-bind (x e) decl
610 (let ((st (gensym))
611 (p (gensym)))
612 `#'(lambda (,st)
613 (inner-let! ((,p (funcall ,e ,st)))
614 (let ((,x (state-value ,p)))
615 (funcall ,m (state-state ,p))))))))
616 decls
617 :from-end t
618 :initial-value m))
619
620 (defun state-trans-progn! (ms)
621 (reduce #'(lambda (m1 m2)
622 (let ((st (gensym))
623 (p (gensym)))
624 `#'(lambda (,st)
625 (inner-let! ((,p (funcall ,m1 ,st)))
626 (funcall ,m2 (state-state ,p))))))
627 ms
628 :from-end t))
629
630 (defun state-trans-run! (m init-st)
631 (let ((p (gensym)))
632 `(inner-let! ((,p (funcall ,m ,init-st)))
633 (inner-unit
634 (list (state-value ,p)
635 (state-state ,p))))))
636
637 (defun state-trans-get! ()
638 (let ((st (gensym)))
639 `#'(lambda (,st)
640 (inner-unit
641 (make-state ,st ,st)))))
642
643 (defun state-trans-put! (new-st)
644 (let ((st (gensym)))
645 `#'(lambda (,st)
646 (declare (ignore ,st))
647 (inner-unit
648 (make-state nil ,new-st)))))
649
650 (defun state-trans-lift! (m)
651 (let ((st (gensym))
652 (a (gensym)))
653 `#'(lambda (,st)
654 (inner-let! ((,a ,m))
655 (inner-unit
656 (make-state ,a ,st))))))
657
658 (defmacro with-state-monad-trans (inner-monad &body body)
659 `(with-monad-trans (with-state-monad-trans ,inner-monad)
660 (macrolet
661 ((unit (a) (state-trans-unit a))
662 (funcall! (k m) (state-trans-funcall! k m))
663 (progn! (&body ms) (state-trans-progn! ms))
664 (let! (decls m) (state-trans-let! decls m))
665 (get! () (state-trans-get!))
666 (put! (new-st) (state-trans-put! new-st))
667 (run! (m init-st) (state-trans-run! m init-st))
668 (lift! (m) (state-trans-lift! m)))
669 ,@body)))
670
671 ;;;
672 ;;; The Writer Monad Transformer
673 ;;;
674
675 (defun writer-trans-write! (ws)
676 (if (= 1 (length ws))
677 ;; An optimized case
678 (let ((w (nth 0 ws))
679 (v (gensym)))
680 `(inner-unit
681 (make-writer nil
682 (let ((,v ,w))
683 #'(lambda (xs) (cons ,v xs))))))
684 ;; A general case
685 (let ((vs (gensym)))
686 `(inner-unit
687 (make-writer nil
688 (let ((,vs (list ,@ws)))
689 #'(lambda (xs)
690 (append ,vs xs))))))))
691
692 (defun writer-trans-write-list! (wss)
693 (if (= 1 (length wss))
694 ;; An optimized case
695 (let ((ws (nth 0 wss))
696 (vs (gensym)))
697 `(inner-unit
698 (make-writer nil
699 (let ((,vs ,ws))
700 #'(lambda (xs) (append ,vs xs))))))
701 ;; A general case
702 (let ((vss (gensym)))
703 `(inner-unit
704 (make-writer nil
705 (let ((,vss (list ,@wss)))
706 #'(lambda (xs)
707 (reduce #'append ,vss
708 :from-end t
709 :initial-value xs))))))))
710
711 (defun writer-trans-run! (m)
712 (let ((x (gensym))
713 (fun (gensym)))
714 `(inner-let! ((,x ,m))
715 (inner-unit
716 (list (writer-value ,x)
717 (let ((,fun (writer-fun ,x)))
718 (if (not (null ,fun))
719 (funcall ,fun nil))))))))
720
721 (defun writer-trans-unit (a)
722 `(inner-unit
723 (make-writer ,a nil)))
724
725 (defun writer-trans-funcall! (k m)
726 (let ((ks (gensym))
727 (ms (gensym))
728 (a (gensym))
729 (ka (gensym)))
730 `(let ((,ks ,k))
731 (inner-let! ((,ms ,m))
732 (let ((,a (writer-value ,ms)))
733 (inner-let! ((,ka (funcall ,ks ,a)))
734 (inner-unit
735 (make-writer (writer-value ,ka)
736 (writer-compose (writer-fun ,ms)
737 (writer-fun ,ka))))))))))
738
739 (defun writer-trans-let! (decls m)
740 (reduce
741 #'(lambda (decl m)
742 (destructuring-bind (x e) decl
743 (let ((es (gensym))
744 (ms (gensym)))
745 `(inner-let! ((,es ,e))
746 (let ((,x (writer-value ,es)))
747 (inner-let! ((,ms ,m))
748 (inner-unit
749 (make-writer (writer-value ,ms)
750 (writer-compose (writer-fun ,es)
751 (writer-fun ,ms))))))))))
752 decls
753 :from-end t
754 :initial-value m))
755
756 (defun writer-trans-progn! (ms)
757 (reduce
758 #'(lambda (m1 m2)
759 (let ((m1s (gensym))
760 (m2s (gensym)))
761 `(inner-let! ((,m1s ,m1)
762 (,m2s ,m2))
763 (inner-unit
764 (make-writer (writer-value ,m2s)
765 (writer-compose (writer-fun ,m1s)
766 (writer-fun ,m2s)))))))
767 ms
768 :from-end t))
769
770 (defun writer-trans-lift! (m)
771 (let ((a (gensym)))
772 `(inner-let! ((,a ,m))
773 (inner-unit
774 (make-writer ,a nil)))))
775
776 (defmacro with-writer-monad-trans (inner-monad &body body)
777 `(with-monad-trans (with-writer-monad-trans ,inner-monad)
778 (macrolet
779 ((unit (a) (writer-trans-unit a))
780 (funcall! (k m) (writer-trans-funcall! k m))
781 (progn! (&body ms) (writer-trans-progn! ms))
782 (let! (decls m) (writer-trans-let! decls m))
783 (write! (&body ws) (writer-trans-write! ws))
784 (write-list! (&body wss) (writer-trans-write-list! wss))
785 (run! (m) (writer-trans-run! m))
786 (lift! (m) (writer-trans-lift! m)))
787 ,@body)))

  ViewVC Help
Powered by ViewVC 1.1.5