;;;; Representing Monads -- Andrzej Filinski

;;; Reification and reflection

(define (reify monad)
  (let ((unit (monad-unit monad)))
    (lambda (exp)
      (reset (lambda () (unit (exp)))))))

(define (reflect monad)
  (let ((bind (monad-bind monad)))
    (lambda (v)
      (shift (lambda (k) (bind v k))))))


;;; Monads

(define make-monad list)
(define monad-unit first)
(define monad-bind second)

(define (in-left x)
  (cons 'left x))

(define (in-right x)
  (cons 'right x))

(define (sum-case x f g)
  (case (car x)
    ((left) (f (cdr x)))
    ((right) (g (cdr x)))))


;; Nondeterminism: TA = List A

(define list-monad
  (make-monad
   list
   (lambda (c f)
     (reduce append '() (map f c)))))

(define list-reify (reify list-monad))
(define list-reflect (reflect list-monad))

(define (amb x y)
  (list-reflect
   (append (list-reify (lambda () x))
	   (list-reify (lambda () y)))))

(define (amb2 thunk-x thunk-y)
  (list-reflect
   (append (list-reify thunk-x)
	   (list-reify thunk-y))))

(define (fail)
  (list-reflect '()))

#|
(list-reify
 (+ (amb 1 2) (amb 10 20)))
|#


;; Exceptions: TA = A + E

(define exception-monad
  (make-monad
   in-left
   (lambda (c f)
     (sum-case c f in-right))))

(define exception-reify (reify exception-monad))
(define exception-reflect (reflect exception-monad))

(define (raise e)
  (exception-reflect (in-right e)))

(define (handle exp h)
  (sum-case (exception-reify exp) identity-procedure h))

#|
(handle (lambda () (+ 1 2))
	identity-procedure)

(handle (lambda () (+ 1 (raise "foo")))
	identity-procedure)
|#