[software/python-on-guile.git] / 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!
                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 (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 (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-)
  (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)
        (lambda x (apply f x))
        (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)
        (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 '__zub_classes__)
                 (hash-set! it class #t)
                 #f)
            
            (aif it (ref p '__init_subclass__)
                 (apply it class p #f kw)
                 #f))))
    (set class '__mro__ (cons class (find-in-class-and-parents
                                     class '__mro__ '())))
    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)
    (pk 'res class)))


(define (the-create-object class x)
  (let* ((meta  (ref class '__class__))
         (goops (ref class '__goops__))
         (obj   (aif it (ficap class '__new__ #f)
                     (apply it class x)
                     (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 (create-object class x)
  (if (pytype? class)
      (apply type-call class x)
      (let ((meta (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)
                  (ref 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 (ref meta '__class__)
         (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-method (find-in-class (klass <p>) key fail)
  (hash-ref (slot-ref klass 'h) key fail))
  
(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 (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-syntax-rule (mrefx-py x key l)
  (let ((xx x))
    (let* ((f (aif it (or (mrefx xx '__getattribute__ '())
                          (mrefx xx '__getattr__ '()))
                   (gox xx it)
                   #f)))
      (if (or (not f) (eq? f not-implemented))
          (gox xx (mrefx xx key l))
          (catch #t
                 (lambda () (gox xx (f xx key)))
                 (lambda z  (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 (ref v '__class__)
             (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 (ref 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))))
      (pk 'got cl)
      (aif it (ref meta '__init_subclass__)
           (let lp ((ps cparents))
             (if (pair? ps)
                 (let ((super (car ps)))
                   (it cl super)
                   (lp (cdr ps)))))
           #f)
      (pk 'return)
      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 (ref 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 (ref 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
        (if (or (pyclass? obj) (pytype? obj))
            cl
            (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 . l)
                                         (aif it (ficap c key #f)
                                              (if (procedure? it)
                                                  (gokx obj cl it)
                                                  it)
                                              (error "no attribute"))))
              (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 (ref cl '__bases__))))

(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))
       '()))

(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)

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

(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)))