(define-module (language python for)
  #:use-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 (language python persist)
  #:export (for break next wrap-in))

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

(eval-when (compile eval load)
  (define (generate-temporaries2 x)
    (map (lambda (x) (generate-temporaries x)) x)))

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

(define-syntax for
  (syntax-rules (:)
    ((for ((x ... : E) ...) ((c n) ...) code ... #:final fin)
     (for-work #f ((x ... : E) ...) ((c n) ...) (code ...) fin))
    
    ((for lp ((x ... : E) ...) ((c n) ...) code ... #:final fin)
     (for-work lp ((x ... : E) ...) ((c n) ...) (code ...) fin))
    
    ((for ((x ... : E) ...) ((c n) ...) code ...)
     (for-work #f ((x ... : E) ...) ((c n) ...) (code ...) (values)))
    
    ((for lp ((x ... : E) ...) ((c n) ...) code ...)
     (for-work lp ((x ... : E) ...) ((c n) ...) (code ...) (values)))))
    
(define-syntax for-work
  (lambda (x)
    (define (wrap-continue lp code)
      (if (syntax->datum lp)
          #`(lambda () (let/ec #,lp #,@code))
          #`(lambda ()              #,@code)))
      
    (syntax-case x ()
      ((for lp ((x ... : E) ...) ((c n) ...) (code ...) fin)
       (with-syntax (((It ...)       (generate-temporaries #'(E ...)))
                     ((cc ...)       (generate-temporaries #'(c ...)))
                     (((x1 ...) ...) (generate-temporaries2 #'((x ...) ...)))
                     (((x2 ...) ...) (generate-temporaries2 #'((x ...) ...)))
                     ((N ...)        (map length #'((x ...) ...)))
                     (llp            (if (syntax->datum #'lp) #'lp #'lpu)))
         
         #`(let/ec lp-break
             (syntax-parameterize ((break (lambda (z)
                                            (syntax-case z ()
                                              ((_ . l)
                                               #'(lp-break . l))
                                              (_ #'lp-break)))))
                                  
               (let ((It (wrap-in E)) ...
                     (c  n          ) ...
                     (x  'None      ) ... ...
                     (x1 #f         ) ... ...)
                 (catch StopIteration
                   (lambda ()
                     (let llp ((cc c) ...)                                
                       (set! c cc) ...
                       (call-with-values
                           (lambda () (next It))
                         (let ((f
                                (lambda (x2 ...)
                                  (set! x1 x2) ...)))
                           (if (> N 1)
                               (case-lambda
                                 ((q)
                                  (apply f q))
                                 (q
                                  (apply f q)))
                               (lambda (x2 ... . ll)
                                 (set! x1 x2) ...))))
                       ...
                       (set! x x1)
                       ... ...
                       (call-with-values
                           #,(wrap-continue #'lp #'(code ...))
                         (lambda (cc ... . q) (llp cc ...)))))
                   (lambda q fin))))))))))

(define-class <scm-list>   () l)
(define-class <scm-string> () s i)

(name-object <scm-list>)
(name-object <scm-string>)
(cpit <scm-list> (o (lambda (o l) (slot-set! o 'l l))
		    (list (slot-ref o 'l))))
(cpit <scm-string> (o (lambda (o s i)
			(slot-set! o 's s)
			(slot-set! o 'i i))
		      (list
		       (slot-ref o 's)
		       (slot-ref o 'i))))

(define-method (next (l <scm-list>))
  (let ((ll (slot-ref l 'l)))
    (if (pair? ll)
        (begin
          (slot-set! l 'l (cdr ll))
          (car ll))
        (throw StopIteration))))

(define-method (next (l <scm-string>))
  (let ((s (slot-ref l 's))
        (i (slot-ref l 'i)))
    (if (= i (string-length s))
        (throw StopIteration)
        (begin
          (slot-set! l 'i (+ i 1))
          (string-ref s i)))))

(define-method (next (l <yield>))
  (let ((k (slot-ref l 'k))
        (s (slot-ref l 's)))
    (if k
        (k (lambda () 'None))
        (s))))

(define-method (wrap-in (o <yield>))
  o)

(define-method (wrap-in (o <p>))
  (aif it (ref o '__iter__)
       (it)
       (next-method)))

(define-method (next (l <p>))
  ((ref l '__next__)))

(define-method (wrap-in x)
  (cond
   ((pair? x)
    (let ((o (make <scm-list>)))
      (slot-set! o 'l x)
      o))
   
   ((string? x)
    (let ((o (make <scm-string>)))
      (slot-set! o 's x)
      (slot-set! o 'i 0)
      o))
   
   (else
    x)))

(set! (@@ (oop pf-objects) hashforeach)
  (lambda (f d)
    (for ((k v : d)) () (f k v))))

#;
(pk
 (for c ((x : (gen '(1 2 3)))) ((s 0))
      (pk x)
      (if (> x 2) (c s))
      (+ s x)

      #:final
      s))