(define-module (oop pf-objects)
  #:use-module (oop goops)
  #:use-module (ice-9 vlist)
  #:use-module (ice-9 match)
<<<<<<< HEAD
  #:use-module (system base message)
  #:use-module (language python guilemod)
=======
  #:use-module (ice-9 pretty-print)
>>>>>>> d71244f5cb87a4a61a6b341e4838a38e50142815
  #:use-module (logic guile-log persistance)
  #:replace (equal?)  
  #:export (set ref make-p <p> <py> <pf> <pyf> <property>
                call with copy fset fcall put put!
                pcall pcall! get fset-x pyclass?                
                def-p-class   mk-p-class   make-p-class
                define-python-class get-type py-class
                object-method class-method static-method
                py-super-mac py-super py-equal? 
                *class* *self* pyobject? pytype?
                type object pylist-set! pylist-ref tr
		resolve-method rawref rawset
                ))

#|
Python object system is basically syntactic suger otop of a hashmap and one
this project is inspired by the python object system and what it measn when
one in stead of hasmaps use functional hashmaps. We use vhashes, but those have a drawback in that those are not thread safe. But it is a small effort to work
with assocs or tree like functional hashmaps in stead.

The hashmap works like an assoc e.g. we will define new values by 'consing' a
new binding on the list and when the assoc take up too much space it will be
reshaped and all extra bindings will be removed.

The datastructure is functional but the objects mutate. So one need to 
explicitly tell it to not update etc.
|#

(define fail (cons 'fail '()))

(define-syntax-rule (kif it p x y)
  (let ((it p))
    (if (eq? it fail)
	y
	x)))

(define-method (pylist-set! (o <hashtable>) key val)
  (hash-set! o key val))

(define-method (pylist-ref (o <hashtable>) key)
  (kif it (hash-ref o key fail)
       it
       (error "IndexError")))

(define (is-acl? a b) (member a (cons b (class-subclasses b))))

(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
(define-class <p>  (<applicable-struct> <object>) h)
(define-class <pf> (<p>) size n)         ; the pf object consist of a functional
                                         ; hashmap it's size and number of live
                                         ; object
(define-class <py>  (<p>))
(define-class <pyf> (<pf>))

(define-class <property> () get set del)

(name-object <p>)
(name-object <pf>)
(name-object <py>)
(name-object <pyf>)
(name-object <property>)

(define (resolve-method-g g pattern)
  (define (mmatch p pp)
    (if (eq? pp '_)
	'()
	(match (cons p pp)
	  (((p . ps) . (pp . pps))
	   (if (eq? pp '_)
	       (mmatch ps pps)
	       (if (is-a? p pp)
		   (cons p (mmatch ps pps))
		   #f)))
	  ((() . ())
	   '())
	  (_
	   #f))))

  (define (q< x y)
    (let lp ((x x) (y y))
      (match (cons x y)
	(((x . xs) . (y . ys))
	 (and (is-a? x y)
	      (lp xs ys)))
	(_ #t))))
  
  (let ((l
	 (let lp ((ms (generic-function-methods g)))
	   (if (pair? ms)
	       (let* ((m (car ms))
		      (p (method-specializers m))
		      (f (method-generic-function m)))
		 (aif it (mmatch p pattern)
		     (cons (cons it f) (lp (cdr ms)))
		     (lp (cdr ms))))
	       '()))))
    
    
    (cdr (car (sort l q<)))))

(define (resolve-method-o o pattern)
  (resolve-method-g (class-of o) pattern))
  
(define (get-dict self name parents)
  (aif it (ref self '__prepare__)
       (it self name parents)
       (make-hash-table)))

(define (hashforeach a b) (values))

(define (new-class meta name parents dict kw)
  (aif it (ref meta '__new__)
       (apply it name parents dict kw)
       (let* ((goops (pylist-ref dict '__goops__))
              (p     (kwclass->class kw meta))
              (class (make-p p)))
	 (slot-set! class 'procedure
                    (lambda x
                      (create-object class meta goops x)))
         (if (hash-table? dict)
             (hash-for-each
              (lambda (k v) k (set class k v))
              dict)
             (hashforeach
              (lambda (k v) k (set class k v))
              dict))
         (let((mro (ref class '__mro__)))
           (if (pair? mro)
               (let ((p (car mro)))
                 (aif it (ref p '__init_subclass__)
                      (apply it class #f kw)
                      #f))))
         (set class '__mro__ (cons class (ref class '__mro__)))
         class)))

(define (type- meta name parents dict keys)
  (let ((class (new-class meta name parents dict keys)))
    (aif it (ref meta '__init__)
         (it name parents dict keys)
         #f)
    class))

(define (create-class meta name parents gen-methods . keys)
  (let ((dict (gen-methods (get-dict meta name keys))))
    (aif it (ref meta '__class__)
         (aif it (find-in-class (ref meta '__class__) '__call__ #f)
              (apply (it meta 'class) name parents dict keys)
              (type- meta name parents dict keys))
         (type- meta name parents dict keys))))

(define (create-object class meta goops x)
  (with-fluids ((*make-class* #t))
    (aif it #f ;(ref meta '__call__)
       (apply it x)       
       (let ((obj (aif it (find-in-class class '__new__ #f)
                       ((it class 'object))
                       (make-object class meta goops))))        
         (aif it (ref obj '__init__)
              (apply it x)
              #f)
         (slot-set! obj 'procedure
                    (lambda x
                      (aif it (ref obj '__call__)
                           (apply it x)
                           (error "not a callable object"))))
         obj))))

(define (make-object class meta goops)
  (let ((obj (make-p goops)))
    (set obj '__class__ class)
    obj))

;; Make an empty pf object
(define (make-p <x>)
  (let ((r (make <x>)))
    (cond
     ((is-a? r <pf>)
      (slot-set! r 'h vlist-null)
      (slot-set! r 'size 0)
      (slot-set! r 'n 0))
     ((is-a? r <p>)
      (slot-set! r 'h (make-hash-table)))
     (else
      (error "make-p in pf-objects need a <p> or <pf> derived class got ~a"
             r)))
    r))


(define-syntax-rule (hif it (k h) x y)
  (let ((a (vhash-assq k h)))
    (if (pair? a)
        (let ((it (cdr a)))
          x)
        y)))

(define-syntax-rule (cif (it h) (k cl) x y)
  (let* ((h (slot-ref cl 'h))
         (a (vhash-assq k h)))
    (if (pair? a)
        (let ((it (cdr a)))
          x)
        y)))

(define-syntax-rule (mrefx x key l)
  (let ()
    (define (end)
      (if (null? l)
          #f
          (car l)))

    (define (parents li)
      (let lp ((li li))
        (if (pair? li)
            (let ((p (car li)))
              (cif (it h) (key p)
                   it
		   (lp (cdr li))))
            fail)))
  
    (cif (it h) (key x)
         it
         (hif cl ('__class__ h)
              (cif (it h) (key cl)
                   it
                   (hif p ('__mro__ h)
                        (let ((r (parents p)))
                          (if (eq? r fail)
                              (end)
                              r))
                        (end)))
              (end)))))

(define *refkind* (make-fluid 'object))

(define-method (find-in-class (klass <p>) key fail)
  (hash-ref (slot-ref klass 'h) key fail))

(define-method (find-in-class (klass <pf>) key fail)
  (let ((r (vhash-assoc key (slot-ref klass 'h))))
    (if r
	(cdr r)
	fail)))

(define-syntax-rule (find-in-class-and-parents klass key fail)
  (kif r (find-in-class klass key fail)
       r
       (aif parents (find-in-class klass '__mro__ #f)
	    (let lp ((parents parents))
	      (if (pair? parents)
		  (kif r (find-in-class (car parents) key fail)
		       r
		       (lp (cdr parents)))
		  fail))
	    fail)))

(define-syntax-rule (mrefx klass key l)
  (let ()
    (define (end) (if (pair? l) (car l) #f))
    (fluid-set! *refkind* 'object)
    (kif it (find-in-class klass key fail)
	 it
	 (begin
	   (fluid-set! *refkind* 'class)
	   (aif klass (find-in-class klass '__class__ #f)
		(kif it (find-in-class-and-parents klass key fail)
		     it
		     (end))
		(end))))))

(define not-implemented (cons 'not 'implemeneted))

(define-syntax-rule (prop-ref xx x)
  (let ((y xx)
        (r x))
      (if (and (is-a? r <property>) (not (pyclass? y)))
          ((slot-ref r 'get) y)
          r)))

(define-syntax-rule (mrefx-py x key l)
  (let ((xx x))
    (prop-ref
     xx
     (let* ((g (mrefx xx '__fget__ '(#t)))
	    (f (if g
		   (if (eq? g #t)
		       (aif it (mrefx xx '__getattribute__ '())
			    (begin
			      (mset xx '__fget__ it it)
			      it)
			    (begin
			      (if (mc?)
				  (mset xx '__fget__ it it))
			      #f))
		       g)
		   #f)))
       (if (or (not f) (eq? f not-implemented))
	   (mrefx xx key l)
	   (catch #t
		  (lambda () ((f xx (fluid-ref *refkind*)) key))
		  (lambda x
		    (mrefx xx key l))))))))


(define-syntax-rule (mref x key l)
  (let ((xx x))
    (let ((res (mrefx xx key l)))
      (if (and (not (struct? res)) (procedure? res))
	  (res xx (fluid-ref *refkind*))
	  res))))

(define-syntax-rule (mref-py x key l)
  (let ((xx x))
    (let ((res (mrefx-py xx key l)))
      (if (and (not (struct? res)) (procedure? res))
	  (res xx (fluid-ref *refkind*))
	  res))))

(define-method (ref x key . l) (if (pair? l) (car l) #f))
(define-method (ref (x <pf> )  key . l) (mref     x key l))
(define-method (ref (x <p>  )  key . l) (mref     x key l))
(define-method (ref (x <pyf>)  key . l) (mref-py  x key l))
(define-method (ref (x <py> )  key . l) (mref-py  x key l))

(define-method (rawref (x <pf> )  key . l) (mref     x key l))
(define-method (rawref (x <p>  )  key . l) (mref     x key l))


(define-method (set (f <procedure>) key val)
  (set-procedure-property! f key val))

(define-method (ref (f <procedure>) key . l)
  (aif it (assoc key (procedure-properties f))
       (cdr it)
       (if (pair? l) (car l) #f)))


;; the reshape function that will create a fresh new pf object with less size
;; this is an expensive operation and will only be done when we now there is
;; a lot to gain essentially tho complexity is as in the number of set
(define (reshape x)
  (let ((h (slot-ref x 'h))
        (m (make-hash-table))
        (n 0))
    (define h2 (vhash-fold (lambda (k v s)
                             (if (hash-ref m k #f)
                                 s
                                 (begin
                                   (hash-set! m k #t)
                                   (set! n (+ n 1))
                                   (vhash-consq k v s))))
                           vlist-null
                           h))
    (slot-set! x 'h h2)
    (slot-set! x 'size n)
    (slot-set! x 'n    n)
    (values)))

;; on object x add a binding that key -> val
(define-method (mset (x <pf>) key rval val)
  (let ((h (slot-ref x 'h))
        (s (slot-ref x 'size))
        (n (slot-ref x 'n)))
    (slot-set! x 'size (+ 1 s))
    (let ((r (vhash-assoc key h)))
      (when (not r)
        (slot-set! x 'n (+ n 1)))
      (slot-set! x 'h (vhash-cons key val h))
      (when (> s (* 2 n))
        (reshape x))
      (values))))

(define (pkh h) (hash-for-each (lambda x (pk x)) h) h)

(define-method (mset (x <p>) key rval val)
  (begin
    (hash-set! (slot-ref x 'h) key val)
    (values)))

(define *make-class* (make-fluid #f))
(define (mc?) (not (fluid-ref *make-class*)))

(define-syntax-rule (mset-py x key rval val)
  (let* ((xx x)
	 (v  (mref xx key (list fail))))
    (if (or (eq? v fail)
	    (not (and (is-a? v <property>)
		      (not (pyclass? xx)))))
	(let* ((g (mrefx xx '__fset__ '(#t)))
	       (f (if g
		      (if (eq? g #t)
			  (aif it (mrefx xx '__setattr__ '())
			       (begin
				 (mset xx '__fset__ it it)
				 it)
			       (begin
				 (if (mc?)
				     (mset xx '__fset__ it it))
				 #f))
			  g)
		      #f)))
	  (if (or (eq? f not-implemented) (not f))
	      (mset xx key val val)              
	      (catch #t
	        (lambda () ((f xx (fluid-ref *refkind*)) key rval))
		(lambda x (mset xx key val val)))))
	((slot-ref v 'set) xx val))))

(define-syntax-rule (mklam (mset a ...) val)
  (if (and (procedure? val)
           (not (pyclass? val))
           (not (pytype?  val))
           (if (is-a? val <p>)
               (ref val '__call__)
               #t))
      (if (procedure-property val 'py-special)
          (mset a ... val val)
          (mset a ... val (object-method val)))
      (mset a ... val val)))

(define-method (set (x <pf>)  key val) (mklam (mset     x key) val))
(define-method (set (x <p>)   key val) (mklam (mset     x key) val))
(define-method (set (x <pyf>) key val) (mklam (mset-py  x key) val))
(define-method (set (x <py>)  key val) (mklam (mset-py  x key) val))

(define-method (rawset (x <pf>)  key val) (mklam (mset     x key) val))
(define-method (rawset (x <p>)   key val) (mklam (mset     x key) val))

;; mref will reference the value of the key in the object x, an extra default
;; parameter will tell what the fail object is else #f if fail
;; if there is no found binding in the object search the class and
;; the super classes for a binding

;; call a function as a value of key in x with the object otself as a first
;; parameter, this is pythonic object semantics
(define-syntax-rule (mk-call mcall mref)
  (define-syntax-rule (mcall x key l)
    (apply (mref x key '()) l)))

(mk-call mcall     mref)
(mk-call mcall-py  mref-py)
  
(define-method (call (x <pf>)  key . l) (mcall     x key l))
(define-method (call (x <p>)   key . l) (mcall     x key l))
(define-method (call (x <pyf>) key . l) (mcall-py  x key l))
(define-method (call (x <py>)  key . l) (mcall-py  x key l))


;; make a copy of a pf object
(define-syntax-rule (mcopy x)
  (let ((r (make-p (ref x '__goops__))))
    (slot-set! r 'h (slot-ref x 'h))
    (slot-set! r 'size (slot-ref x 'size))
    (slot-set! r 'n (slot-ref x 'n))
    r))

(define-syntax-rule (mcopy- x)
  (let* ((r (make-p (ref x '__goops__)))
         (h (slot-ref r 'h)))
    (hash-for-each (lambda (k v) (hash-set! h k v)) (slot-ref x 'h))
    r))

(define-method (copy (x <pf>)) (mcopy  x))
(define-method (copy (x <p> )) (mcopy- x))

;; make a copy of a pf object
(define-syntax-rule (mtr r x)
  (begin
    (slot-set! r 'h    (slot-ref x 'h   ))
    (slot-set! r 'size (slot-ref x 'size))
    (slot-set! r 'n    (slot-ref x 'n   ))
    (values)))

(define-syntax-rule (mtr- r x)
  (begin
    (slot-set! r 'h (slot-ref x 'h))
    (values)))
  

(define-method (tr (r <pf>) (x <pf>)) (mtr  r x))
(define-method (tr (r <p> ) (x <p> )) (mtr- r x))
  

;; with will execute thunk and restor x to it's initial state after it has
;; finished note that this is a cheap operatoin because we use a functional
;; datastructure
(define-syntax-rule (mwith x thunk)
  (let ((old (mcopy x)))
    (let ((r (thunk)))
      (slot-set! x 'h    (slot-ref old 'h))
      (slot-set! x 'size (slot-ref old 'size))    
      (slot-set! x 'n    (slot-ref old 'n))
      r)))

(define-syntax-rule (mwith- x thunk)
  (let ((old (mcopy- x)))
    (let ((r (thunk)))
      (slot-set! x 'h    (slot-ref old 'h))
      r)))



;; a functional set will return a new object with the added binding and keep
;; x untouched
(define-method (fset (x <pf>) key val)
  (let ((x (mcopy x)))
    (mset x key val val)
    x))

(define-method (fset (x <p>) key val)
  (let ((x (mcopy- x)))
    (mset x key val val)
    x))

(define (fset-x obj l val)
  (let lp ((obj obj) (l l) (r '()))
    (match l
      (()
       (let lp ((v val) (r r))
         (if (pair? r)
             (lp (fset (caar r) (cdar r) v) (cdr r))
             v)))
      ((k . l)
       (lp (ref obj k #f) l (cons (cons obj k) r))))))



           

;; a functional call will keep x untouched and return (values fknval newx)
;; e.g. we get both the value of the call and the new version of x with
;; perhaps new bindings added
(define-method (fcall (x <pf>) key . l)
  (let* ((y (mcopy x))
         (r (mcall y key l)))
    (if (eq? (slot-ref x 'h) (slot-ref y 'h))
        (values r x)
        (values r y))))

(define-method (fcall (x <p>) key . l)
  (let ((x (mcopy x)))
    (values (mcall x key l)
            x)))

;; this shows how we can override addition in a pythonic way

;; lets define get put pcall etc so that we can refer to an object like
;; e.g. (put x.y.z 1) (pcall x.y 1)

(define-syntax-rule (cross x k f set)
  (call-with-values (lambda () f)
    (lambda (r y)
      (if (eq? x y)
          (values r x)
          (values r (set x k y))))))

(define-syntax-rule (cross! x k f _) f)

(define-syntax mku
  (syntax-rules ()
    ((_ cross set setx f (key) (val ...))
     (setx f key val ...))
    ((_ cross set setx f (k . l) val)
     (cross f k (mku cross set setx (ref f k) l val) set))))

(define-syntax-rule (mkk pset setx set cross)
  (define-syntax pset
    (lambda (x)   
      (syntax-case x ()
        ((_ f val (... ...))
         (let* ((to (lambda (x)
                      (datum->syntax #'f  (string->symbol x))))
                (l (string-split (symbol->string (syntax->datum #'f)) #\.)))
           (with-syntax (((a (... ...)) (map (lambda (x) #`'#,(to x))
                                             (cdr l)))
                         (h       (to (car l))))
             #'(mku cross setx set h (a (... ...)) (val (... ...))))))))))

(mkk put    fset  fset cross)
(mkk put!   set   set  cross!)
(mkk pcall! call  fset cross!)
(mkk pcall  fcall fset cross)
(mkk get    ref   fset cross!)

;; it's good to have a null object so we don't need to construct it all the
;; time because it is functional we can get away with this.
(define null (make-p <pf>))

(define (filter-parents l)
  (let lp ((l l))
    (if (pair? l)
        (if (is-a? (car l) <p>)
            (cons (car l) (lp (cdr l)))
            (lp (cdr l)))
        '())))

(define (kw->class kw meta)
  (if (memq #:functional kw)
      (if (memq #:fast kw)
          <pf>
          (if (or (not meta) (is-a? meta <pyf>) (is-a? meta <py>))
              <pyf>
              <pf>))              
      (if (memq #:fast kw)
          (if (or (is-a? meta <pyf>) (is-a? meta <pf>))
              <pf>
              <p>)
          (cond
           ((is-a? meta <pyf>)
            <pyf>)
           ((is-a? meta <py>)
            <py>)
           ((is-a? meta <pf>)
            <pf>)
           ((is-a? meta <p>)
            <p>)
           (else
            <py>)))))
           

(define (defaulter d)
  (if d
      (cond
       ((is-a? d <pyf>)
        <pyf>)
       ((is-a? d <py>)
        <py>)
       ((is-a? d <pf>)
        <pf>)
       ((is-a? d <p>)
        <p>)
       (else
        d))
      <py>))

(define (kwclass->class kw default)
  (if (memq #:functionalClass kw)
      (if (memq #:fastClass kw)
          <pf>
          (if (memq #:pyClass kw)
              <pyf>
              (if (or (is-a? default <py>) (is-a? default <pyf>))
                  <pyf>
                  <pf>)))
      (if (memq #:mutatingClass kw)
          (if (memq #:fastClass kw)
              <p>
              (if (memq #:pyClass kw)
                  <py>
                  (if (or (is-a? default <py>) (is-a? default <pyf>))
                      <py>
                      <p>)))
          (if (memq #:fastClass kw)
              (if (or (is-a? default <pf>) (is-a? default <pyf>))
                  <pf>
                  <p>)
              (if (memq #:pyClass kw)
                  (if (or (is-a? default <pf>) (is-a? default <pyf>))
                      <pyf>
                      <py>)
                  (defaulter default))))))

(define object #f)
(define (make-p-class name supers.kw methods)
  (define kw      (cdr supers.kw))
  (define supers  (car supers.kw))
  (define goopses (map (lambda (sups)
                         (aif it (ref sups '__goops__ #f)
                              it
                              sups))
                       supers))
  (define parents (let ((p (filter-parents supers)))
                    (if (null? p)
                        (if object
                            (list object)
                            '())
                        p)))
  
  (define meta (aif it (memq #:metaclass kw)
                    (car it)
                    (if (null? parents)
                        type
                        (let* ((p   (car parents))
                               (m   (ref p '__class__))
                               (mro (reverse (ref m '__mro__))))
                          (let lp ((l   (cdr parents))
                                   (max mro)
                                   (min mro))
                            (if (pair? l)
                                (let* ((p    (car l))
                                       (meta (ref p '__class__))
                                       (mro  (ref meta '__mro__)))
                                  (let lp2 ((max max) (mr (reverse mro)))
                                    (if (and (pair? max) (pair? mr))
                                        (if (eq? (car max) (car mr))
                                            (lp2 (cdr max) (cdr mr))
                                            (error
                                             "need a common lead for meta"))
                                        (if (pair? max)
                                            (if (< (length mro) (length min))
                                                (lp (cdr l) max mro)
                                                (lp (cdr l) max min))
                                            (lp (cdr l) mro min)))))
                                (car (reverse min))))))))
  
  (define goops (make-class (append goopses (list (kw->class kw meta)))
                            '() #:name name))
    
  (define (gen-methods dict)
    (methods dict)
    (pylist-set! dict '__goops__   goops)
    (pylist-set! dict '__class__   meta)
    (pylist-set! dict '__fget__    #t)
    (pylist-set! dict '__fset__    #t)
    (pylist-set! dict '__name__    name)
    (pylist-set! dict '__parents__ parents)
    (pylist-set! dict '__class__   meta)
    (pylist-set! dict '__mro__     (get-mro parents))
    dict)

  (with-fluids ((*make-class* #t))
    (create-class meta name parents gen-methods kw)))


;; Let's make an object essentially just move a reference

;; the make class and defclass syntactic sugar
(define-syntax mk-p-class
  (lambda (x)
    (syntax-case x ()
      ((_ name parents (ddef dname dval) ...)
       (with-syntax (((ddname ...)
		      (map (lambda (dn)
			     (datum->syntax
			      #'name
			      (string->symbol
			       (string-append
				(symbol->string
				 (syntax->datum #'name))
				"-"
				(symbol->string
				 (syntax->datum dn))))))
			   #'(dname ...)))
		     (nname (datum->syntax
			     #'name
			     (string->symbol
			      (string-append
			       (symbol->string
				(syntax->datum #'name))
			       "-goops-class")))))
         (%add-to-warn-list (syntax->datum #'nname))
         (map (lambda (x) (%add-to-warn-list (syntax->datum x)))
              #'(ddname ...))
	#'(let ()
	    (define name 
	      (letruc ((dname dval) ...)
		      (make-p-class 'name
				    parents
				    (lambda (dict)
				      (pylist-set! dict 'dname dname)
				      ...
				      (values)))))

	    (begin
	      (module-define! (current-module) 'ddname (ref name 'dname))
	      (name-object ddname))
	    ...

	    (module-define! (current-module) 'nname (ref name '__goops__))
	    (name-object nname)
	    (name-object name)
	    name))))))

(define-syntax-rule (def-p-class name . l)
  (define name (mk-p-class name . l)))

(define (get-class o)
  (cond
   ((is-a? o <p>)
    o)
   (else
    (error "not a pyclass"))))

(define (get-type o)
  (cond
   ((is-a? o <pyf>)
    'pyf)
   ((is-a? o <py>)
    'py)
   ((is-a? o <pf>)
    'pf)
   ((is-a? o <p>)
    'p)
   (else
    'none)))

(define (print o l)
  (define p (if (pyclass? o) "C" (if (pyobject? o) "O" "T")))
  (define port (if (pair? l) (car l) #t))
  (format port "~a"
          (aif it (if (pyclass? o)
                      #f
                      (if (pyobject? o)
                          (ref o '__repr__)
                          #f))
               (format
                #f "~a(~a)<~a>"
                p (get-type o) (it))
               (format
                #f "~a(~a)<~a>"
                p (get-type o) (ref o '__name__ 'Annonymous)))))

(define-method (write   (o <p>) . l) (print o l))
(define-method (display (o <p>) . l) (print o l))

(define (arglist->pkw l)
  (let lp ((l l) (r '()))
    (if (pair? l)
        (let ((x (car l)))
          (if (keyword? x)
              (cons (reverse r) l)
              (lp (cdr l) (cons x r))))
        (cons (reverse r) '()))))

(define-syntax-rule (define-python-class name (parents ...) code ...)
  (define name (mk-p-class name (arglist->pkw (list parents ...)) code ...)))


(define-syntax make-python-class
  (lambda (x)
    (syntax-case x ()
      ((_ name (parents ...) code ...)
       #'(let* ((cl  (mk-p-class name
				 (arglist->pkw (list parents ...))
				 code ...)))
	   cl)))))
    

(define (kind x)
  (and (is-a? x <p>)
       (aif it (find-in-class x '__goops__ #f)
            (if (is-a? (make it) (ref type '__goops__))
                'type
                'class)
            'object)))

(define (pyobject? x) (eq? (kind x) 'object))
(define (pyclass?  x) (eq? (kind x) 'class))
(define (pytype?   x) (eq? (kind x) 'type))

(define (mark-fkn tag f)
  (set-procedure-property! f 'py-special tag)
  f)

(define (object-method f)
  (letrec ((self
            (mark-fkn 'object
                      (lambda (x kind)
			(if (eq? kind 'object)
			    f
			    (lambda z (apply f x z)))))))
    self))

(define (class-method f)
  (letrec ((self
            (mark-fkn 'class
              (lambda (x kind)
		(if (eq? kind 'object)
		    (let ((klass (ref x '__class__)))
		      (lambda z (apply f klass z)))
		    (lambda z (apply f x z)))))))
    self))

(define (static-method f)
  (letrec ((self
            (mark-fkn 'static
                      (lambda (x kind) f))))
    self))

        
(define-syntax-parameter
  *class* (lambda (x) (error "*class* not parameterized")))
(define-syntax-parameter
  *self* (lambda (x) (error "*class* not parameterized")))

(define *super* (list 'super))

(define (not-a-super) 'not-a-super)
(define (py-super class obj)
  (define (make cl parents)
    (let ((c (make-p <p>))
          (o (make-p <p>)))
      (set c '__super__        #t)
      (set c '__mro__       parents)
      (set c '__getattribute__  (lambda (self key . l)
                                  (aif it (ref c key)
                                       (if (procedure? it)
                                           (if (eq? (procedure-property
                                                     it
                                                     'py-special)
                                                    'class)
                                               (it cl)
                                               (it obj))
                                           it)
                                       (error "no attribute"))))
      (set o '__class__ c)
      o))
  
  (call-with-values
      (lambda ()
        (let lp ((l (ref (ref obj '__class__) '__mro__ '())))
          (if (pair? l)
              (if (eq? class (car l))
                  (let ((r (cdr l)))
                    (if (pair? r)
                        (values (car r) r)
                        (values #f      #f)))
                  (lp (cdr l)))
              (values #f #f))))
    make))
        
        
   
(define-syntax py-super-mac
  (syntax-rules ()
    ((_)
     (py-super *class* *self*))
    ((_ class self)
     (py-super class self))))

(define (pp x)
  (pretty-print (syntax->datum x))
  x)

(define-syntax letruc
  (lambda (x)
    (syntax-case x ()
      ((_ ((x v) ...) code ...)
       (let lp ((a #'(x ...)) (b #'(v ...)) (u '()))
         (if (pair? a)
             (let* ((x (car a))
                    (s (syntax->datum x)))
               (let lp2 ((a2 (cdr a)) (b2 (cdr b)) (a3 '()) (b3 '())
                         (r (list (car b))))
                 (if (pair? a2)
                     (if (eq? (syntax->datum a2) s)
                         (lp2 (cdr a2) (cdr b2) a3 b3 (cons (car b2) r))
                         (lp2 (cdr a2) (cdr b2)
                              (cons (car a2) a3)
                              (cons (car b2) b3)
                              r))
                     (lp (reverse a3) (reverse b3)
                         (cons
                          (list x #`(let* #,(map (lambda (v) (list x v))
                                                 (reverse r)) #,x))
                          u)))))
             #`(letrec #,(reverse u) code ...)))))))
                        

             
       
(define-method (py-init (o <p>) . l)
  (apply (ref o '__init__) l))

(define mk-tree
  (case-lambda
   ((root)
    (vector root '()))
   ((root hist) (vector root hist))))

(define (geth t) (vector-ref t 1))
(define (getr t) (vector-ref t 0))
(define (tree-ref t) (car (getr t)))

(define (nxt tree)  
  (define (dive r h)
    (let ((x (car r)))
      (if (pair? x)
	  (dive (car r) (cons (cdr r) h))
	  (mk-tree r h))))
  
  (define (up r h)
    (if (null? r)
	(if (pair? h)
	    (up (car h) (cdr h))
	    #f)
	(let ((x (car r)))
	  (if (pair? x)
	      (dive r h)
	      (mk-tree r h)))))
	 
  (let ((r (getr tree)) (h (geth tree)))
    (cond
     ((pair? r)
      (let ((r (cdr r)))
	(if (pair? r)
	    (let ((x (car r)))
	      (if (pair? x)
		  (dive x (cons (cdr r) h))
		  (mk-tree r h)))
	    (if (pair? h)
		(up (car h) (cdr h))
		#f))))
     (else
      (if (pair? h)
	  (up (car h) (cdr h))
	  #f)))))

(define (class-to-tree cl) (cons cl (map class-to-tree (ref cl '__parents__))))

(define (find-tree o tree)
  (if tree
      (let ((x (tree-ref tree)))
	(if (eq? o x)
	    #t
	    (find-tree o (nxt tree))))
      #f))

(define (get-mro parents)
  (if (null? parents)
      parents
      (get-mro0 parents)))

(define (get-mro0 parents)  
  (define tree (mk-tree parents))
  (let lp ((tree tree) (r '()))
    (if tree
        (let ((x (tree-ref tree))
              (n (nxt tree)))
          (if (find-tree x n)
              (lp n r)
              (lp n (cons x r))))
        (reverse r))))

(define-method (py-equal? (x <p>)  y)
  (aif it (ref x '__eq__)
       (it y)
       (next-method)))

(define-method (py-equal? y (x <p>))
  (aif it (ref x '__eq__)
       (it y)
       (next-method)))

(define-method (py-equal? x y) ((@ (guile) equal?) x y))

(define (equal? x y) (or (eq? x y) (py-equal? x y)))

(define type #f)
(set! type
      (make-python-class type ()
        (define __call__
          (case-lambda
            ((meta obj)
             (ref obj '__class__ 'None))
            ((meta name bases dict . keys)
             (type- meta name bases dict keys))))))
(set type '__class__ type)

(set! object (make-python-class object ()))

(name-object type)
(name-object object)