(define-module (language python persist)
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist)
  #:use-module (ice-9 pretty-print)
  #:use-module (oop goops)
  #:use-module (oop pf-objects)
  #:use-module (persist persistance)
  #:re-export(pcopyable? deep-pcopyable? pcopy deep-pcopy name-object
			 name-object-deep)
  #:export (reduce cp red cpit))

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

(define (vhash->assoc v)
  (let ((t (make-hash-table)))
    (vhash-fold
     (lambda (k v s)
       (if (hash-ref t k)
	       s
	       (begin
	         (hash-set! t k #t)
	         (cons (cons k v) s))))
     '() v)))

(define-method (pcopyable?      (o <p>)) #t)
(define-method (deep-pcopyable? (o <p>)) #t)

(define (cp o)
  (match (red o)
	((#:reduce mk f)
	 (let ((oo (mk)))
	   (for-each (lambda (x) (apply (car x) oo (cdr x))) f)
	   oo))))

(define (red o)
  (fluid-set! first #t)
  (list #:reduce
	    (let ((cl (class-of o)))
	      (lambda () (make cl)))
	    (reduce o)))
  

(define-method (pcopy (o <p>))
  (list #:obj
	    (aif it (ref o '__copy__)
	         (it)
	         (cp o))))

(define-method (deep-pcopy (o <p>) p?)
  (aif it (and p? (ref o '__deepcopy__))
       (list #:obj  (it))
       (red o)))

(define first (make-fluid #f))
(define-method (reduce o) '())
(define-method (reduce (o <p>))
  (if (fluid-ref first)
      (begin
	    (fluid-set! first #f)
	    (cons
	     (aif it (ref o '__reduce__)
	          (it)
	          (cons
	           (lambda (o args)
		         (let ((h (make-hash-table)))
		           (slot-set! o 'h h)
		           (for-each
		            (lambda (x) (hash-set! h (car x) (cdr x)))
		            args)))
	           (list
		        (hash-fold
		         (lambda (k v s) (cons (cons k v) s))
		         '()
		         (slot-ref o 'h)))))
	     (next-method)))
      (next-method)))

(define (fold f s l)
  (if (pair? l)
      (fold f (f (car l) s) (cdr l))
      s))

(define-method (reduce (o <pf>))
  (if (fluid-ref first)
      (begin
	    (fluid-set! first #f)
	    (cons*
	     (cons
	      (lambda (o n args)
	        (slot-set! o 'size n)
	        (slot-set! o 'n    n)
	        (let ((h
		           (fold
		            (lambda (k v s) (vhash-assoc k v s))
		            vlist-null
		            args)))
	          (slot-set! o 'h h)))
	      (list (slot-ref o 'n) (vhash->assoc (slot-ref o 'h))))
	     (next-method)))
      (next-method)))
     
(define-syntax cpit
  (lambda (x)
    (syntax-case x ()
      ((_ <c> (o lam a))
       #'(begin    
	       (define-method (pcopyable?      (o <c>)   ) #t)
	       (define-method (deep-pcopyable? (o <c>)   ) #t)
	       (define-method (pcopy           (o <c>)   ) (cp o))
	       (define-method (deep-pcopy      (o <c>) p?) (red o))
	       (define-method (reduce          (o <c>)   )
	         (cons*
	          (cons lam a)
	          (next-method))))))))