(define-module (oop pf-objects) #:use-module (oop goops) #:use-module (ice-9 vlist) #:use-module (ice-9 match) #:replace (equal?) #:export (set ref make-pf
( ) size n) ; the pf object consist of a functional
; hashmap it's size and number of live
; object
(define-class ))
(define-class )
(let ((r (ref x '__const__))
(h (make-hash-table)))
(hash-set! h '__class__ x)
(slot-set! o 'h h))
o))))
(define-method (get-dict (self ) name parents)
(aif it (find-in-class self '__prepare__ #f)
(it self name parents)
(make )))
(define-method (new-class (self ) name parents dict)
(aif it (ref self '__new__)
(it self name parents dict)
(let ((class (make (ref dict '__goops__))))
(slot-set! class 'procedure
(aif it (ref self '__call__)
(lambda x (apply __call__ x))
(lambda x
(let ((obj (py-make-obj class)))
(aif it (ref obj '__init__)
(apply it x)
(values))
obj)))
class)
(cond
((is-a? dict )
(slot-set! class 'h (slot-ref dict 'h)))
(else
(slot-set! class 'h dict))))))
(define (create-class meta name parents gen-methods keys)
(let ((dict (gen-methds (get-dict meta name keys))))
(aif it (find-in-class (ref meta '__class__) '__call__ #f)
((it meta 'object) meta name parents keywords)
(let ((class (aif it (find-in-class meta '__new__ #f)
((it meta 'object) meta name parents dict keys)
(new-class meta name parents dict keys))))
(aif it (find-in-class meta '__init__)
((it meta 'object) name parents
;; Make an empty pf object
(define* (make-pf #:optional (class ))
(define r (make-pyclass class))
(slot-set! r 'h (make-hash-table))
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 fail (cons 'fail '()))
(define-syntax-rule (mrefx x key l)
(let ()
(define (end)
(if (null? l)
#f
(car l)))
(define (parents li)
(let lp ((li li))
(if (pair? li)
(let ((p (car li)))
(cif (it h) (key p)
it
(lp (cdr li))))
fail)))
(cif (it h) (key x)
it
(hif cl ('__class__ h)
(cif (it h) (key cl)
it
(hif p ('__mro__ h)
(let ((r (parents p)))
(if (eq? r fail)
(end)
r))
(end)))
(end)))))
(define *refkind* (make-fluid 'object))
(define-method (find-in-class (klass ) key fail)
(hash-ref (slot-ref klass 'h) key fail))
(define-method (find-in-class (klass ) key . l) (mref x key l))
(define-method (ref (x ) key . l) (mref x key l))
(define-method (refq (x ) key val)
(begin
(hash-set! (slot-ref x 'h) key val)
(values)))
(define-method (mset (x )
(ref val '__call__)
#t))
(if (procedure-property val 'py-special)
(mset a ... val)
(mset a ... (object-method val)))
(mset a ... val)))
(define-method (set (x ) key val) (mklam (mset x key) val))
(define-method (set (x ) key . l) (mcall x key l))
(define-method (call (x )) (mcopy- 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 ) key val)
(let ((x (mcopy- x)))
(mset x key 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 ) 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-pf))
;; append the bindings in x in front of y + some optimizations
(define (union x y)
(define hx (slot-ref x 'h))
(define hy (slot-ref y 'h))
(define n (slot-ref x 'n))
(define s (slot-ref x 'size))
(define m (make-hash-table))
(define h
(vhash-fold
(lambda (k v st)
(if (vhash-assq k hy)
(begin
(set! s (+ s 1))
(vhash-consq k v st))
(if (hash-ref m k)
s
(begin
(set! n (+ n 1))
(set! s (+ s 1))
(hash-set! m k #t)
(vhash-consq k v st)))))
hy
hx))
(define out (make-pyclass )
(cons (car l) (lp (cdr l)))
(lp (cdr l)))
'())))
(define-syntax-rule (mk-p make-p-class )
(define-syntax make-p-class
(lambda (x)
(syntax-case x ()
((_ name const dynamic (supers (... ...)))
(with-syntax (((sups (... ...)) (generate-temporaries
#'(supers (... ...)))))
#'(let ((sups supers) (... ...))
(define name (make-class (list
(if (is-a? sups )
(aif it (ref sups '__goops__ #f)
it
sups)
sups)
(... ...) ) '()))
(define class (dynamic ))
(set class '__class__ #f)
(set class '__fget__ #t)
(set class '__fset__ #t)
(set class '__name__ 'name)
(set class '__goops__ name)
(set class '__parents__ (filter-parents (list sups (... ...))))
(set class '__mro__ (get-mro class))
class)))))))
(mk-p make-p-class )
(mk-p make-py-class )
o)
(else
(error "not a pyclass"))))
(define (get-type o)
(cond
((is-a? o )
'p)
(else
'none)))
(define (print o l)
(define p1 (if (pyclass? o) "C" "O"))
(define p2 (if (pyclass? o) "C" "O"))
(define port (if (pair? l) (car l) #t))
(format port "~a"
(aif it (if (pyclass? o) #f (ref o '__repr__ #f))
(format
#f "~a(~a)<~a>" p1 (get-type o) (it))
(format
#f "~a(~a)<~a>" p2 (get-type o) (ref o '__name__ 'None)))))
(define-method (write (o ) . l) (print o l))
(define-method (display (o ) . l) (print o l))
(define-syntax-rule (define-python-class name parents code ...)
(define name
(mk-py-class name parents
#:const
()
#:dynamic
(code ...))))
(define (pyclass? x)
(and (is-a? x )
(if (ref x '__class__)
#f
(if (ref x '__super__)
'super
#t))))
(define-method (py-class (o ))
(ref o '__class__ 'type))
(define (mark-fkn tag f)
(set-procedure-property! f 'py-special tag)
f)
(define (object-method f)
(letrec ((self
(mark-fkn 'object
(lambda (x kind)
(if (eq? kind 'object)
f
(lambda z (apply f x z)))))))
self))
(define (class-method f)
(letrec ((self
(mark-fkn 'class
(lambda (x kind)
(if (eq? kind 'object)
(let ((klass (ref x '__class__)))
(lambda z (apply f klass z)))
(lambda z (apply f x z)))))))
self))
(define (static-method f)
(letrec ((self
(mark-fkn 'static
(lambda (x kind) f))))
self))
(define-syntax-parameter
*class* (lambda (x) (error "*class* not parameterized")))
(define-syntax-parameter
*self* (lambda (x) (error "*class* not parameterized")))
(define *super* (list 'super))
(define (not-a-super) 'not-a-super)
(define (py-super class obj)
(define (make cl parents)
(let ((c (make-p))
(o (make-p)))
(set c '__super__ #t)
(set c '__mro__ parents)
(set c '__getattribute__ (lambda (self key . l)
(aif it (ref c key)
(if (procedure? it)
(if (eq? (procedure-property
it
'py-special)
'class)
(it cl)
(it obj))
it)
(error "no attribute"))))
(set o '__class__ c)
o))
(call-with-values
(lambda ()
(let lp ((l (ref (ref obj '__class__) '__mro__ '())))
(if (pair? l)
(if (eq? class (car l))
(let ((r (cdr l)))
(if (pair? r)
(values (car r) r)
(values #f #f)))
(lp (cdr l)))
(values #f #f))))
make))
(define-syntax py-super-mac
(syntax-rules ()
((_)
(py-super *class* *self*))
((_ class self)
(py-super class self))))
(define-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 ) . l)
(apply (ref o '__init__) l))
(define mk-tree
(case-lambda
((root)
(vector root '()))
((root hist) (vector root hist))))
(define (geth t) (vector-ref t 1))
(define (getr t) (vector-ref t 0))
(define (tree-ref t) (car (getr t)))
(define (nxt tree)
(define (dive r h)
(let ((x (car r)))
(if (pair? x)
(dive (car r) (cons (cdr r) h))
(mk-tree r h))))
(define (up r h)
(if (null? r)
(if (pair? h)
(up (car h) (cdr h))
#f)
(let ((x (car r)))
(if (pair? x)
(dive r h)
(mk-tree r h)))))
(let ((r (getr tree)) (h (geth tree)))
(cond
((pair? r)
(let ((r (cdr r)))
(if (pair? r)
(let ((x (car r)))
(if (pair? x)
(dive x (cons (cdr r) h))
(mk-tree r h)))
(if (pair? h)
(up (car h) (cdr h))
#f))))
(else
(if (pair? h)
(up (car h) (cdr h))
#f)))))
(define (class-to-tree cl) (cons cl (map class-to-tree (ref cl '__parents__))))
(define (find-tree o tree)
(if tree
(let ((x (tree-ref tree)))
(if (eq? o x)
#t
(find-tree o (nxt tree))))
#f))
(define (get-mro class)
(define tree (mk-tree (class-to-tree class)))
(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 ) y)
(aif it (ref x '__eq__)
(it y)
(next-method)))
(define-method (py-equal? y (x ))
(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)))