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 find-in-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
                ref-class fastref fastset
                ))

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

;; this is mutated by the dict class
(define dictNs  '(dictNs))
(define dictRNs '(dictRNs))

(define prophash (make-hash-table))

(define (procedure-property- o key . l)
  (define ret (if (pair? l) (car l) #f))    
  (aif props (hashq-ref prophash o)
       (aif it (assq key props)
            (cdr it)
            ret)
       ret))

(define (procedure-properties- o)
  (define ret #f)
  (aif props (hashq-ref prophash o)
       props
       ret))

(define (set-procedure-property!- o key v)
  (hashq-set! prophash
              o
              (aif props (hashq-ref prophash o)
                   (cons (cons key v) props)
                   (list (cons key v)))))

(define (set-procedure-properties!- o l)
  (hashq-set! prophash o l))

#;
(define (pkk . l)
  (let* ((r (reverse l))
         (x (reverse (cdr r)))
         (z (car r)))
    (apply pk x)
    z))


(define (pkk . l)
  (car (reverse l)))

(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__ __class__))
			 (pk k v)
			 (pk k))) h)
    
    (pk 'finished-obj)
    
    (let lp ((l (pk 'mro (rawref 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 (fastref o k . e)
  (define r (if (pair? e) (car e) #f))
  (let ((h (slot-ref o 'h)))
    (if (hash-table? h)
        (hash-ref (slot-ref o 'h) k r)
        (aif it (vhash-assoc k (slot-ref o 'h)) (cdr it) r))))

(define (fastset o k v)
  (let ((h (slot-ref o 'h)))
    (if (hash-table? h)
        (hash-set! (slot-ref o 'h) k v)
        (slot-set! o 'h
                   (vhash-cons k v (slot-ref o 'h))))))

(define-method (pylist-set! (o <p>) key val)
  (aif it (ref o '__setitem__)
       (it key val)
       (next-method)))

(define-method (pylist-ref (o <p>) key)
  (aif it (ref o '__getitem__)
       (it key)
       (next-method)))

(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 inclass (make-fluid #f))
(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
	      (kif it (py-get dict (symbol->string key) fail)
		   it
		   (hash-ref h key -fail)))
	 (hash-ref h key -fail))))

(define-method (find-in-class x key fail) fail)
(define-method (find-in-class-raw klass key fail) fail)

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

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


(define-syntax-rule (find-in-class-and-parents klass key fail-)
  (kif r (find-in-class klass key fail)
       r
       (aif parents (let ((x (find-in-class-raw klass '__mro__ #f)))
                      (if (null? x)
                          #f
                          x))
            (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 (find-in-class-and-parents-raw klass key fail-)
  (aif parents (find-in-class-raw klass '__mro__ #f)
       (let lp ((parents parents))
         (if (pair? parents)
             (kif r (find-in-class-raw (car parents) key fail)
                  r
                  (lp (cdr parents)))
             fail-))
       (kif r (find-in-class-raw klass key fail)
            r
            fail-)))

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

(define-inlinable (ficap-raw klass key fail)
  (find-in-class-and-parents-raw 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-procedure 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 (add-default c l)
  (if (pair? l)
      (let ((l (let ((y (car l))) (if (eq? y c) l (cons c l)))))        
        (let* ((r (reverse l))
               (x (car r)))
          (if x
              (if (or (not type) (pytype? x))
                  (if (or (not type) (eq? x type))
                      l
                      (reverse (cons type r)))
                  (if (or (not object) (eq? x object))
                      l
                      (reverse (cons object r))))
              l)))
      (if object
          (if (pytype? c)
              (list c type)
              (list c object))
         (cons c l))))

(define hash-for-each* hash-for-each)

(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 (project-goopses supers)
  (map (lambda (sups)
         (aif it (find-in-class sups '__goops__ #f)
              it
              sups))
       supers))

(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 (get-goops meta name parents kw)
  (define (unique l)
    (define t (make-hash-table))
    (let lp ((l l))
      (if (pair? l)
          (let ((c (car l)))
            (if (hashq-ref t c)
                (lp (cdr l))
                (begin
                  (hashq-set! t c #t)
                  (cons c (lp (cdr l))))))
          '())))
  
  (make-class
   (unique
    (append
     (project-goopses parents)
     (list (kw->class kw meta)))) '() #:name name))

(define (get-cparents supers)
  (let ((parents (filter-parents supers)))
    (if (null? parents)
        (if object
            (list object)
            '())
        parents)))

(define (get-mros supers)
  (get-mro (get-cparents supers)))

(define (Module x . l) (reverse x))

(define (add-specials pylist-set! dict name goops supers meta doc)
  (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))
          (Module (reverse l) (reverse (cdddr l)))
          l)))
  
  (define parents  (filter-parents supers))
  (define cparents (get-cparents supers))

  (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))))
          '())))
      
  (pylist-set! dict '__goops__    goops)
  (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 '__name__     name)
  (pylist-set! dict '__qualname__ name)
  (pylist-set! dict '__mro__      (get-mro cparents))
  (if doc (pylist-set! dict '__doc__      doc))
  (pylist-set! dict '__class__    meta))

(define (new-class0 meta name parents dict . kw)
  (set! name (if (symbol? name) name (string->symbol name)))
  (let* ((raw?    #f)
         (goops   (catch #t
                    (lambda () (pylist-ref dict '__goops__))
                    (lambda x
                      (set! raw? #t)
                      (get-goops meta name parents kw))))
	 (p       (kwclass->class kw meta))
	 (class   (make-p p)))
    
    (slot-set! class 'procedure
	       (lambda x
		 (create-object class x)))

    (when class
      (let lp ((mro  (catch #t
                       (lambda () (pylist-ref dict '__mro__))
                       (lambda x  (get-mros parents)))))
                        
        (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)))))
      
      (hash-for-each*
       (lambda (k v)
         (let ((k (if (string? k) (string->symbol k) k)))
           (rawset class k v)))
       dict)

      (if raw?
          (begin
            (add-specials rawset class name goops parents meta
                          (catch #t
                            (lambda () (pylist-ref kw "doc"))
                            (lambda x #f)))
            (set (rawref class '__module__)
                 (if (string? name) (string->symbol name) name)
                 class))
          (rawset class '__goops__ goops))

      (let ((mro (add-default class
                              (catch #t
                                (lambda () (pylist-ref dict '__mro__))
                                (lambda x (get-mros parents))))))
        (rawset class '__mro__ mro))

      (catch #t
        (lambda ()
          (if (not (ficap-raw class '__getattribute__ #f))
              (rawset class '__getattribute__ attr)))
        (lambda x
          (rawset class '__getattribute__ attr))))

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

    (when (struct? obj)
      (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-raw class '__class__ #f))))
	(with-fluids ((*make-class* #t))
	  (aif it (ficap meta '__call__ #f)
	       (apply it class x)
	       (the-create-object class x))))))

;; This are finished in the _python.scm module
(define int-cls    #f)
(define int?       #f)
(define tuple-cls  #f)
(define tuple?     #f)
(define string-cls #f)
(define str?       #f)
(define bytes-cls  #f)
(define bytes?     #f)
(define list-cls   #f)
(define list?      #f)
(define float-cls  #f)
(define float?     #f)

(define (check-obj obj)
  (cond
   ((int?    obj) int-cls)
   ((tuple?  obj) tuple-cls)
   ((float?  obj) float-cls)
   ((str?    obj) string-cls)
   ((list?   obj) list-cls)
   ((bytes?  obj) bytes-cls)
   (else
    object)))
                 
(define type-call
  (lambda (class . l)
    (if (pytype? class)
        (apply (case-lambda
                 ((meta obj)
                  (catch #t
                    (lambda ()
                      (aif it (find-in-class-raw obj '__class__ #f)
                           it
                           (check-obj obj)))
                    (lambda x
                      (warn x)
                      (check-obj obj))))
                  
                 ((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))
       (dictNs (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-raw meta '__class__ #f))
         (aif it (ficap-raw 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)))
    (rawset 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-raw 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 (mrefx-py x key l)
  (let ((xx x))
    (define (exit) (if (pair? l) (car l) #f))
    (aif class (find-in-class-raw xx '__class__ #f)
         (aif f (ficap-raw class '__getattribute__ #f)
              (kif it (if (eq? f __getattribute__)
                          (f xx key)
                          (catch #t
                            (lambda ()
                              (f xx (symbol->string key)))
                            (lambda q fail)))
                              
                   it
                   (exit))
              (kif it (__getattribute__ xx key)
                   it
                   (exit)))
         #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-syntax-rule (mox o x)
  (if (and (procedure? x) (not (is-a? x <p>)))
      (aif it (procedure-property- x '__get__)
           (it x o (fluid-ref *location*))
           x)))

(define-method (ref (x <pf> )  key . l) (mox x (mref     x key l)))
(define-method (ref (x <p>  )  key . l) (mox x (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 __setattr__
  (lambda (self key1 val)
    (define key (if (string? key1) (string->symbol key1) key1))
    (let ((h (aif dict (rawref self '__dict__)
                  dict
                  (slot-ref self 'h))))
      (kif desc (py-get h key fail)
           (aif it (rawref desc '__set__ #f)
                (it self val)
                (pylist-set! h key val))
           (pylist-set! h key val)))))

(define (mset-py x key val)
  (let* ((xx x))
    (aif class (find-in-class-raw xx '__class__ #f)
         (aif f (find-in-class-and-parents-raw class '__setattr__ #f)
              (if (eq? f __setattr__)
                  (f            xx key val)
                  (f            xx (symbol->string key) val))
              (__setattr__  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 (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 parents  (filter-parents supers))
    (define cparents (get-cparents supers))
    (define meta (aif it (memq #:metaclass kw)
		      (cadr it)
		      (if (null? cparents)
			  type
			  (let* ((p   (car cparents))
				 (m   (rawref p '__class__))
				 (mro (reverse (ref m '__mro__ '()))))
                            (let lp ((l (cdr cparents)) (m m) (mro mro))
                              (match l
                                ((pp . l)
                                 (aif mm (rawref pp '__class__)
                                      (aif mmro (rawref mm '__mro__)
                                           (cond
                                            ((memq m mmro)
                                             (lp l mm mmro))
                                            ((memq mm mro)
                                             (lp l m  mro))
                                            (error "TypeError for meta"))
                                           (lp l m mro))
                                      (lp l m mro)))
                                (() m)))))))
                                  
    (define goops (get-goops meta name supers kw))
    
    (define (gen-methods dict)      
      (methods dict)
      (add-specials pylist-set! dict name goops supers meta 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
               (let ((pa parents))
                 (letruc2 ((dname (make-up dval)) ...)
                          body
                          (let ((ret
                                 (make-p-class 'name doc
                                               pa
                                               (lambda (dict)
                                                 (pylist-set! dict 'dname dname)
                                                 ...
                                                 dict))))
                            (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 z)
  (begin
    (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)
                            z
                            #f))
                 (format
                  #f "~a(~a)<~a>"
                  p (get-type o) (it))
                 (format
                  #f "~a(~a)<~a>"
                  p (get-type o) (aif it (find-in-class-raw
                                          o '__name__ #f)
                                      it
                                      (ref
                                       o '__name__ 'Annonymous)))))))

(define-method (write   (o <p>) . l)
  (aif it (ref o '__repr__)
       (print o l it)
       (print o l #f)))

(define-method (display (o <p>) . l)
    (aif it (ref o '__repr__)
       (print o l it)
       (print o l #f)))

(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-cache (make-hash-table))
(define (kind-cache-it type it)
  (hashq-set! kind-cache type it)
  type)

(define (kind x)
  (if (not type-goops) (set! type-goops (rawref type '__goops__)))      
  (and (is-a? x <p>)
       (aif it (find-in-class-raw x '__goops__ #f)
            (aif it2 (hashq-ref kind-cache it)
                 it2
                 (if (or                 
                      (not type-goops)
                      (eq? it type-goops)
                      (member it (class-subclasses type-goops)))
                     (kind-cache-it 'type  it)
                     (kind-cache-it 'class it)))
            '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>)))
	  (rawset c '__class__        type)
	  (rawset c '__mro__          (cons* c parents))
	  (rawset c '__getattribute__
                  (lambda (self key)
                    (set! key (if (string? key) (string->symbol key) key))
                    (kif it (ficap c key fail)
                         (aif dt (ref it '__get__)
                              (dt obj cl)
                              it)
                         fail)))
	  (rawset c '__name__  "**super**")
	  (rawset o '__class__ c)
	  o)))

  (call-with-values
      (lambda ()
        (let ((ll (ref (ref obj '__class__) '__mro__ '())))
          (if (pair? ll)
              (let lp ((l ll))
                (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 (car ll) ll)))
              (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-syntax letruc2
  (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)))))
             #`(let #,(reverse u) code ...)))))))


             
(define-method (py-init . l)
  (values))

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

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

(define ref-class
  (lambda (self key fail)
    (aif class (find-in-class-raw self '__class__ #f)
         (kif it1 (ficap class key fail)
              (aif dd1 (rawref it1 '__get__)
                   (dd1 self class)
                   it1)
              fail)
         fail)))


(define __getattribute__
  (lambda (self key-)
    (define key (if (string? key-) (string->symbol key-) key-))
    (aif class (find-in-class-raw self '__class__ #f)
         (kif it1 (ficap class key fail)
              (aif dd1 (ref it1 '__get__)
                   (if (ref it1 '__set__)
                       (dd1 self class)
                       (kif it2 (ficap self key fail)
                            it2
                            (dd1 self class)))
                   (kif it2 (ficap self key fail)
                        it2
                        it1))
              (kif it2 (ficap self key fail)
		   (if (pyobject? self)
		       it2
		       (aif dd1 (ref it2 '__get__)
			    (dd1 self self)
			    it2))
                   (aif it (ficap-raw class '__getattr__ #f)
                        (kif it1 (catch #t
                                   (lambda ()
                                     (it self (symbol->string key)))
                                   (lambda x fail))
			     (if (pyobject? self)
				 it1
				 (aif dd1 (ref it1 '__get__)
				      (dd1 self self)
				      it1))
                             fail)
                        fail)))
         fail)))

(define attr __getattribute__)

(define (*str* self . l)
  (scmstr (ref self '__name__)))

(define *setattr* __setattr__)

(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 __str__           *str*)
     (define __getattribute__  attr)
     (define __setattr__       (object-method *setattr*))
     (define __format__        (lambda (self x) (*str* self)))
     (define __reduce_ex__     (lambda x (error "not implemented")))
     (define mro               (lambda (self) (ref self '__mro__)))))

(set type '__class__ type)
(rawset type '__mro__ (list type))

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

(define (scmstr s) (if (symbol? s) (symbol->string s) s))

(set! object
  (make-python-class object ()
    (define __new__          (lambda (class . a)
                               (make-object
                                class
                                (find-in-class-raw class '__class__ #f)
                                (find-in-class-raw class '__goops__ #f))))
    (define __init__         (lambda x (values)))
    (define __subclasses__   subclasses)
    (define __getattribute__ attr)
    (define __setattr__      (object-method *setattr*))
    (define __str__          *str*)
    (define __ne__           (object-method
                              (lambda (self x) (not (equal? self x)))))
    (define __format__        (lambda (self x) (*str* self)))
    (define __reduce_ex__     (lambda x (error "not implemented")))
    (define __weakref__      (lambda (self) self))))

(rawset object '__mro__ (list object))

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

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

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

(define-method (py-dict x)
  (if (eq? x 'None)
      (py-dict NoneObj)
      (make-hash-table)))

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