path: root/modules/oop/pf-objects.scm

(define-module (oop pf-objects)
  #:use-module (oop goops)
  #:use-module (ice-9 vlist)
  #:use-module (ice-9 match)
  #:use-module (system base message)
  #:use-module (language python guilemod)
  #:use-module (ice-9 pretty-print)
  #: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! py-get
                pcall pcall! get fset-x pyclass?                
                def-p-class   mk-p-class   make-p-class mk-p-class2
                define-python-class define-python-class-noname
		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-g rawref rawset py-dict
                ))

#|
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-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))

(define (pk-obj o)
  (pk 'start-pk-obj)
  (let ((h (slot-ref o 'h)))
    (hash-for-each (lambda (k v)
		     (if (member k '(__name__ __qualname__))
			 (pk k v)
			 (pk k))) h)
    
    (pk 'finished-obj)
    
    (let lp ((l (ref o '__mro__ '())))
      (if (pair? l)
	  (let ((cl (car l)))
	    (if (is-a? cl <p>)
		(if (hash-table? (slot-ref cl 'h))
		    (hash-for-each (lambda (k v)
				     (if (member k '(__name__ __qualname__))
					 (pk k v)
					 (pk k)))
				   (slot-ref cl 'h))
		    (pk 'no-hash-table))
		(pk 'no-class))
	    (lp (cdr l)))))

    (pk 'end-pk-obj)))

(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-method (py-get x key . l)
  (if (pair? l) (car l) #f))

(define-method (py-get (o <hashtable>) key . l)
  (define -fail (if (pair? l) (car l) #f))
  (kif it (hash-ref o key fail)
       it
       -fail))

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

(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-method (ref (o <procedure>) key . l)
  (aif it (procedure-property o key)
       it
       (if (pair? l)
	   (car l)
	   #f)))

(define-method (rawref (o <procedure>) key . l)
  (aif it (procedure-property o key)
       it
       (if (pair? l)
	   (car l)
	   #f)))

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

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

(define-method (find-in-class x key fail) 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-method (find-in-class (klass <p>) key -fail)
  (let ((h (slot-ref klass 'h)))
    (aif dict (hash-ref h '__dict__)
         (kif it (py-get dict key fail)
	      it
	      (hash-ref h key -fail))
         (hash-ref h key -fail))))


(define-syntax-rule (find-in-class-and-parents klass key fail-)
  (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-))
       (kif r (find-in-class klass key fail)
            r
            fail-)))

(define-inlinable
  (ficap klass key fail) (find-in-class-and-parents klass key fail))

(define (mk-getter-object f)
  (lambda (obj cls)
    (if (pytype? obj)
	f
        (if (pyclass? obj)
            (if (pytype? cls)                
                (lambda x (apply f obj x))
                f)
            (if (pyclass? cls)
                (lambda x (apply f obj x))
                f)))))

(define (mk-getter-class f)				       
  (lambda (obj cls)
    (lambda x (apply f cls x))))

(define (class-method f)
  (set f '__get__ (mk-getter-class f))
  f)

(define (object-method f)
  (set f '__get__ (mk-getter-object f))
  f)

(define (static-method f)
  (set f '__get__ #f)
  f)


(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 (or (eq? p pp) (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 (hashforeach a b) (values))


(define (new-class0 meta 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 x)))
    
    (if (hash-table? dict)
	(hash-for-each
	 (lambda (k v) k (set class k v))
	 dict)
        (begin (set class '__dict__ dict)))
    
    (let lp ((mro (find-in-class class '__mro__ #f)))
      (if (pair? mro)
	  (let ((p (car mro)))
	    (aif it (find-in-class p '__zub_classes__ #f)
		 (hash-set! it class #t)
		 #f)
	    
	    (aif it (find-in-class p '__init_subclass__ #f)
		 (apply it class p #f kw)
		 #f)
	    
	    (lp (cdr mro)))))
    
    (set class '__mro__ (cons class (find-in-class-and-parents
				     class '__mro__ '())))

    (if (not (ficap class '__getattribute__ #f))
	(set class '__getattribute__ attr))
    (if (not (ficap class 'mro #f))
	(set class 'mro _mro))

    (set class '__class__ meta)
    
    class))

(define (new-class meta name parents dict kw)
  (aif it (and meta (ficap meta '__new__ #f))
       (apply it meta name parents dict kw)
       (apply new-class0 meta name parents dict kw)))

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


(define (the-create-object class x)
  (let* ((meta  (and class (find-in-class class '__class__ #f)))
         (goops (find-in-class class '__goops__ #f))
         (obj   (aif it (ficap class '__new__ #f)
                     (apply it class x)
                     (make-object class meta goops))))
    (aif it (ficap class '__init__ #f)
         (apply it obj x)
         #f)

    (slot-set! obj 'procedure
               (lambda x
                 (aif it (ref obj '__call__)
                      (apply it x)
                      (error "not a callable object"))))
    
    obj))

(define (create-object class x)
  (if (pytype? class)
      (apply type-call class x)
      (let ((meta (and class (find-in-class class '__class__ #f))))
	(with-fluids ((*make-class* #t))
	  (aif it (ficap meta '__call__ #f)
	       (apply it class x)
	       (the-create-object class x))))))

(define type-call
  (lambda (class . l)
    (if (pytype? class)
        (apply (case-lambda
                 ((meta obj)
                  (and obj (find-in-class obj '__class__ 'None)))
                 ((meta name bases dict . keys)
                  (type- meta name bases dict keys)))
               class l)
        (the-create-object class l))))

(define (get-dict self name parents)
  (aif it (and self (ficap self '__prepare__ #f))
       (it self name parents)
       (make-hash-table)))

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

(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-inlinable (gox obj it)
  (let ((class (fluid-ref *location*)))
    (aif f (rawref it '__get__)
	 (f obj class)
	 it)))

(define-inlinable (gokx obj class it)
  (aif f (rawref it '__get__)
       (f obj class)
       it))

(define *location* (make-fluid #f))
(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)
                   (begin (fluid-set! *location* p) it)
		   (lp (cdr li))))
            fail)))
  
    (cif (it h) (key x)
         (begin (fluid-set! *location* x) it)
         (hif cl ('__class__ h)
              (cif (it h) (key cl)
                   (begin (fluid-set! *location* cl) it)
                   (hif p ('__mro__ h)
                        (let ((r (parents p)))
                          (if (eq? r fail)
                              (end)
                              r))
                        (end)))
              (end)))))
  
(define-syntax-rule (mrefx klass key l)
  (let ()
    (define (end) (if (pair? l) (car l) #f))    
    (fluid-set! *location* klass)
    (kif it (find-in-class-and-parents klass key fail)
	 it
	 (aif klass (and klass (find-in-class klass '__class__ #f))
	      (begin
		(fluid-set! *location* klass)
		(kif it (find-in-class-and-parents klass key fail)
		     it
		     (end)))
	      (end)))))

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

(define-inlinable (mrefx-py x key l)
  (let ((xx x))
    (let* ((f (aif it (mrefx xx '__getattribute__ '())
                   it
                   #f)))
      (if (or (not f) (eq? f not-implemented))	  
          (gox xx (mrefx xx key l))
	  (kif it (f xx key)
	       it
	       (if (pair? l) (car l) #f))))))

(define-syntax-rule (mref x key l)
  (let ((xx x))
    (mrefx xx key l)))

(define-syntax-rule (mref-py x key l)
  (let ((xx x))
    (let ((res (mrefx-py xx key l)))
      res)))

(define-method (ref x key . l)
  (cond
   ((eq? x 'None)
    (apply ref NoneObj key l))
   ((pair? l)
    (car l))
   (else
    #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 key . l) (if (pair? l) (car l) #f))
(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 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 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 val)
  (let* ((xx x)
	 (v  (mref xx key (list fail))))
    (if (eq? v fail)
	(let* ((g (mrefx xx '__fset__ '(#t)))
	       (f (if g
		      (if (eq? g #t)
			  (aif it (rawref xx '__setattr__)
			       (begin
				 (rawset xx '__fset__ it)
				 it)
			       (begin
				 (if (mc?)
				     (rawset xx '__fset__ it))
				 #f))
			  g)
		      #f)))
	  (if (or (eq? f not-implemented) (not f))
	      (mset xx key val)              
	      (catch #t
	        (lambda () (f key val))
		(lambda q  (mset xx key val)))))
	
	(aif it (and v (find-in-class v '__class__ #f))
	     (aif it (ref it '__set__)
		  (it val)
		  (mset xx key val))
	     (mset xx key val)))))

(define-syntax-rule (mklam (mset a ...) val)
  (mset a ... 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
      (aif it (ref d '__goops__)
	   it
	   (if (is-a? d <py>)
	       <py>
	       <p>))
      <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 type   #f)
(define object #f)
(define make-p-class
  (case-lambda
   ((name supers.kw methods)
    (make-p-class name "" supers.kw methods))
   ((name doc supers.kw methods)
    (define s.kw    supers.kw)
    (define kw      (cdr s.kw))
    (define supers  (car s.kw))
    (define goopses (map (lambda (sups)
			   (aif it (find-in-class sups '__goops__ #f)
				it
				sups))
			 supers))
    
    (define parents (let ((p (filter-parents supers)))
                      p))
    
    (define cparents (if (null? parents)
                         (if object
                             (list object)
                             '())
                         parents))
    
    (define meta (aif it (memq #:metaclass kw)
		      (cadr it)
		      (if (null? cparents)
			  type
			  (let* ((p   (car cparents))
				 (m   (ref p '__class__))
				 (mro (reverse (ref m '__mro__ '()))))
			    (let lp ((l   (cdr cparents))
				     (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 (make-module)
      (let ((l (module-name (current-module))))
	(if (and (>= (length l) 3)
		 (equal? (list-ref l 0) 'language)
		 (equal? (list-ref l 1) 'python)
		 (equal? (list-ref l 2) 'module))
	    (string-join
	     (map symbol->string (cdddr l))
	     ".")
	    l)))
    
    (define (gen-methods dict)
      (define (filt-bases x)
        (let lp ((x x))
          (if (pair? x)
              (let ((y (car x)))
                (if (is-a? y <p>)
                    (cons y (lp (cdr x)))
                    (lp (cdr x))))
              '())))
      
      (methods dict)
      (pylist-set! dict '__goops__    goops)
      (pylist-set! dict '__class__    meta)
      (pylist-set! dict '__zub_classes__ (make-weak-key-hash-table))
      (pylist-set! dict '__module__   (make-module))
      (pylist-set! dict '__bases__    (filt-bases parents))
      (pylist-set! dict '__fget__     #t)
      (pylist-set! dict '__fset__     #t)
      (pylist-set! dict '__name__     name)
      (pylist-set! dict '__qualname__ name)
      (pylist-set! dict '__class__    meta)
      (pylist-set! dict '__mro__      (get-mro cparents))
      (pylist-set! dict '__doc__      doc)
      dict)

    (let ((cl (with-fluids ((*make-class* #t))
                (create-class meta name parents gen-methods kw))))
      (aif it (ref meta '__init_subclass__)
	   (let lp ((ps cparents))
	     (if (pair? ps)
		 (let ((super (car ps)))
		   (it cl super)
		   (lp (cdr ps)))))
	   #f)
      cl))))
		    


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

;; the make class and defclass syntactic sugar

(define-syntax make-up
  (syntax-rules (lambda case-lambda lambda* letrec letrec*)
    ((_ (lambda . l))
     (object-method (lambda . l)))
    ((_ (case-lambda . l))
     (object-method (case-lambda . l)))
    ((_ (lambda* . l))
     (object-method (lambda* . l)))
    ((_ (letrec . l))
     (object-method (letrec . l)))
    ((_ (letrec* . l))
     (object-method (letrec* . l)))
    ((_ x) x)))

(define-syntax mk-p-class
  (lambda (x)
    (syntax-case x ()
      ((_ name parents (ddef dname dval) ...)
       #'(mk-p-class name parents "" (ddef dname dval) ...))
      ((_ name parents doc (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 (make-up dval)) ...)
		      (let ((ret
			     (make-p-class 'name doc
					   parents
					   (lambda (dict)
					     (pylist-set! dict 'dname dname)
					     ...
					     (values)))))
			(begin
			  (module-define! (current-module) 'ddname dname)
			  (name-object ddname))
			...
			ret)))
	    
	    (module-define! (current-module) 'nname (rawref name '__goops__))
	    (name-object nname)
	    (name-object name)
	    name))))))

(define-syntax mk-p-class2
  (lambda (x)
    (syntax-case x ()
      ((_ name parents ((ddef dname dval) ...) body)
       #'(mk-p-class2 name parents "" ((ddef dname dval) ...) body))
      ((_ name parents doc ((ddef dname dval) ...) body)
       (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 (make-up dval)) ...)
                      body
                      (let ((ret
			     (make-p-class 'name doc
					   parents
					   (lambda (dict)
					     (pylist-set! dict 'dname dname)
					     ...
					     (values)))))
			(begin
			  (module-define! (current-module) 'ddname dname)
			  (name-object ddname))
			...
			ret)))
	    (module-define! (current-module) 'nname (rawref name '__goops__))
	    (name-object nname)
	    (name-object name)
	    name))))))

(define-syntax mk-p-class-noname
  (lambda (x)
    (syntax-case x ()
      ((_ name parents (ddef dname dval) ...)
       #'(mk-p-class-noname name parents "" (ddef dname dval) ...))
      ((_ name parents doc (ddef dname dval) ...)
       #'(let ()
	   (define name 
	     (letruc ((dname dval) ...)
		     (make-p-class 'name doc
				   parents
				   (lambda (dict)
				     (pylist-set! dict 'dname dname)
				     ...
				     (values)))))
	   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
    (syntax-parameterize ((*class* (lambda (x) #'name)))
       (mk-p-class name (arglist->pkw (list parents ...)) code ...))))

(define-syntax-rule (define-python-class-noname name (parents ...) code ...)
  (define name
    (syntax-parameterize ((*class* (lambda (x) #'name)))
      (mk-p-class-noname 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 type-goops #f)
(define (kind x)
  (if (not type-goops) (set! type-goops (ref type '__goops__)))      
  (and (is-a? x <p>)
       (aif it (find-in-class x '__goops__ #f)
            (if (or
                 (not type-goops)
                 (eq? it type-goops)
                 (member it (class-subclasses 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-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)
    (if (not cl)
        #f
        (let ((c (make-p <py>))
	      (o (make-p <py>)))
	  (set c '__class__        type)
	  (set c '__mro__          (cons* c parents))
	  (set c '__getattribute__
	       (lambda (self key)
		 (kif it (ficap c key fail)
		      (aif dt (ref it '__get__)
			   (dt obj cl)
			   it)
		      fail)))
	  (set c '__name__  "**super**")
	  (set o '__class__ c)
	  o)))
  
  (call-with-values
      (lambda ()
        (let lp ((l (ref (if (or (pytype? obj) (pyclass? obj))
			     obj
			     (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
	     (find-in-class cl '__bases__ #f))))

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

(define (linearize x)
  (cond
   ((null? x) x)
   ((pair? x)
    (append (linearize (car x)) (linearize (cdr x))))
   (else (list x))))

(define (get-mro parents)
  (linearize
   (if (null? parents)
       parents
       (get-mro0 (map  class-to-tree 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 (subclasses self)
  (aif it (ref self '__zubclasses__)
       (let ((h (make-hash-table)))
	 (let lp0 ((it it))
	   (let lp ((l (hash-fold
			(lambda (k v s)
			  (hash-set! h k #t)
			  (cons k s))
			'() it)))
	     (if (pair? l)
		 (begin
		   (lp0 (car l))
		   (lp (cdr l))))))

	 (hash-fold (lambda (k v s) (cons k s)) '() h))
       '()))

(define __getattribute__
  (case-lambda
   ((self key)
    (define (-fail class)
      (if (eq? key 'mro)
	  (find-in-class self '__mro__ fail)
	  fail))
    
    (aif class (find-in-class self '__class__ #f)
	 (kif it1 (find-in-class-and-parents class key fail)
	      (aif dd1 (rawref it1 '__get__)
		   (if (rawref it1 '__set__)
		       (dd1 self class)
		       (kif it2 (find-in-class-and-parents self key fail)
			    it2
			    (dd1 self class)))
                    (kif it2 (find-in-class-and-parents self key fail)
                         it2
                         it1))
	      (kif it2 (find-in-class-and-parents self key fail)
		   it2
		   (aif it (find-in-class-and-parents class '__getattr__ #f)
			(kif it1 (it self key)
			     (aif dd1 (rawref it1 '__get__)
				  (dd1 self class)
				  it1)
			     (-fail class))
			(-fail class))))
	 fail))))
             
(define attr __getattribute__)

(set! type
  (make-python-class type ()
     (define __new__           new-class0)
     (define __init_subclass__ (lambda x (values)))
     (define ___zub_classes__  (make-weak-key-hash-table))
     (define __subclasses__    subclasses)
     (define __call__          type-call)
     (define mro               (lambda (self) (ref self '__mro__)))))

(set type '__class__ type)

(define _mro (object-method (lambda (self) (ref self '__mro__))))

(set! object
  (make-python-class object ()
    (define __init__         (lambda x (values)))
    (define __subclasses__   subclasses)
    (define __getattribute__ attr)
    (define __weakref__      (lambda (self) self))
    (define mro              _mro)))
               

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

(define-method (py-class (o <p>))
  (aif it (ref o '__class__)
       it
       (next-method)))


(define-method (py-dict (o <p>))
  (aif it (ref o '__dict__)
       it
       (slot-ref o 'h)))

(define-python-class NoneObj ()
  (define __new__
    (lambda x 'None)))