(define-module (language python yield)
  #:use-module (oop pf-objects)
  #:use-module (language python exceptions)
  #:use-module (oop goops)
  #:use-module (ice-9 control)
  #:use-module (ice-9 match)
  #:replace (send)
  #:export (<yield>
            in-yield define-generator
            make-generator
            sendException sendClose))

(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))

(define in-yield (make-fluid #f))

(define-syntax-parameter YIELD (lambda (x) #f))

(define-syntax yield
  (lambda (x)
    (syntax-case x ()
      ((_ x ...)
       #'(begin
           (fluid-set! in-yield #t)
           ((abort-to-prompt YIELD x ...))))
      (x
       #'(lambda x
           (fluid-set! in-yield #t)
           ((apply abort-to-prompt YIELD x)))))))

(define (make-generator closure)
  (lambda args
    (let ()
      (define obj   (make <yield>))
      (define ab (make-prompt-tag))
      (syntax-parameterize ((YIELD (lambda x #'ab)))
        (slot-set! obj 'k #f)
        (slot-set! obj 'closed #f)
        (slot-set! obj 's
                   (lambda ()
                     (call-with-prompt
                      ab
                      (lambda ()
                        (apply closure yield args)
                        (slot-set! obj 'closed #t)
                        (throw StopIteration))
                      (letrec ((lam
                                (lambda (k . l)
                                  (fluid-set! in-yield #f)
                                  (slot-set! obj 'k
                                             (lambda (a)
                                               (call-with-prompt
                                                ab
                                                (lambda ()
                                                  (k a))
                                                lam)))
                                  (apply values l))))
                        lam))))
        obj))))

(define-syntax-rule (define-generator (f . args) code ...)
  (define f (make-generator args (lambda args code ...))))

(define-class <yield>      () s k closed)

(define-method (send (l <yield>) . u)
  (let ((k (slot-ref l 'k))
        (s (slot-ref l 's))
        (c (slot-ref l 'closed)))
    (if (not c)
        (if k
            (k (lambda ()
                 (if (null? u)
                     'Null
                     (apply values u))))
            (throw 'python (Exception))))))


(define-method (sendException (l <yield>) e . ls)
  (let ((k (slot-ref l 'k))
        (s (slot-ref l 's))
        (c (slot-ref l 'closed)))
    (if (not c)
        (if k           
            (k (lambda ()
                 (if (pyclass? e) 
                     (throw 'python (apply e ls))
                     (apply throw 'python e ls))))
            (throw 'python (Exception))))))

(define-method (sendClose (l <yield>))
  (let ((k (slot-ref l 'k))
        (s (slot-ref l 's))
        (c (slot-ref l 'closed)))
    (if c
        (values)
        (if k
            (catch #t
              (lambda ()
                (k (lambda () (throw 'python GeneratorExit)))
                (slot-set! l 'closed #t)
                (throw 'python RuntimeError))
              (lambda (k tag . v)
                (slot-set! l 'closed #t)
                (if (eq? tag 'python)
                    (match v
                      ((tag . l)
                       (if (eq? tag GeneratorExit)
                           (values)
                           (apply throw tag l))))
                    (apply throw tag v))))
            (slot-set! l 'closed #t)))))

(define-method (send (l <p>) . u)
  (apply (ref l '__send__) u))

(define-method (sendException (l <p>) . u)
  (apply (ref l '__exception__) u))

(define-method (sendClose (l <p>))
  ((ref l '__close__)))