1.1 --- a/experiments/monad/general-monad.scm	Fri May 12 05:09:25 2006 +1200
     1.2 +++ b/experiments/monad/general-monad.scm	Tue Feb 07 11:34:20 2012 -0500
     1.3 @@ -35,23 +35,9 @@
     1.4    (cond
     1.5     ((pair? m) (make-monad *list* m))
     1.6     ((null? m) (make-monad *list* m))
     1.7 -   ((monad? m) (if (eq? (monad-kind m) '_delayed)
     1.8 -		   ((monad-value m))
     1.9 -		   m))
    1.10 +   ((monad? m) m)
    1.11     (else (error "not a monad" m))))
    1.12  
    1.13 -(define-syntax delay-monad
    1.14 -  (syntax-rules ()
    1.15 -    ((_ m) (delay-monad* (lambda () (undelay-monad m))))))
    1.16 -
    1.17 -(define (delay-monad* m)
    1.18 -  (make-monad '_delayed m))
    1.19 -
    1.20 -(define (undelay-monad m)
    1.21 -  (if (and (monad? m) (eq? (monad-kind m) '_delayed))
    1.22 -      ((monad-value m))
    1.23 -      m))
    1.24 -
    1.25  (define (>>= ma a->mb)
    1.26    (let ((ma (monadize ma)))
    1.27      (if (determined? ma)
    1.28 @@ -106,14 +92,19 @@
    1.29  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    1.30  
    1.31  (define *io* (make-monad-class 'io
    1.32 -			       (lambda (io1 f) (delay-monad (f (run-io io1))))
    1.33 +			       (lambda (io1 f) (make-monad *io* (cons (io-action io1) f)))
    1.34  			       (lambda (v) (make-monad *io* (lambda () v)))
    1.35  			       error))
    1.36  
    1.37  (define io-action (monad-arg *io*))
    1.38  
    1.39  (define (run-io m)
    1.40 -  ((io-action m)))
    1.41 +  (let run-action ((action (io-action m)))
    1.42 +    (if (pair? action)
    1.43 +	(let ((previous-action (car action))
    1.44 +	      (continuation (cdr action)))
    1.45 +	  (run-io (continuation (run-action previous-action))))
    1.46 +	(action))))
    1.47  
    1.48  (define (mdisplay x)
    1.49    (make-monad *io* (lambda () (display x) 'done)))