(define-module (oop pf-objects) #:use-module (oop goops) #:use-module (ice-9 vlist) #:use-module (ice-9 match) #: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 (make-pyclass x)
(letrec ((class (make x)))
(slot-set! class 'procedure
(lambda x
(let ((obj (mk class)))
(aif it (ref obj '__init__)
(apply it x)
(values))
obj)))
class))
;; 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
(hif it ('__parents__ h)
(let ((r (parents it)))
(if (eq? r fail)
(lp (cdr li))
r))
(lp (cdr li)))))
fail)))
(cif (it h) (key x)
it
(hif cl ('__class__ h)
(cif (it h) (key cl)
it
(hif p ('__parents__ h)
(let ((r (parents p)))
(if (eq? r fail)
(end)
r))
(end)))
(end)))))
(define-syntax-rule (mrefx- x key l) (mrefx-- (slot-ref x 'h) key l))
(define-syntax-rule (mrefx-- hi key l)
(let ()
(define (end) (if (pair? l) (car l) #f))
(define (ret q) (if (eq? q fail) (end) q))
(define (find-in-class h)
(let lp ((class-h h))
(let ((r (hash-ref class-h key fail)))
(if (eq? r fail)
(aif parents (hash-ref class-h '__parents__ #f)
(let lpp ((parents parents))
(if (pair? parents)
(let ((parent (car parents)))
(let ((r (lp (slot-ref parent 'h))))
(if (eq? r fail)
(lpp (cdr parents))
r)))
fail))
fail)
r))))
(let* ((h hi)
(r (hash-ref h key fail)))
(if (eq? r fail)
(aif class (hash-ref h '__class__)
(ret (find-in-class (slot-ref class 'h)))
(end))
r))))
(define not-implemented (cons 'not 'implemeneted))
(define-syntax-rule (mrefx-py- x key l)
(let ((f (mrefx- x '__getattribute__ '())))
(if (or (not f) (eq? f not-implemented))
(mrefx- x key l)
(apply f x key l))))
(define-syntax-rule (mrefx-py x key l)
(let ((f (mrefx x '__getattribute__ '())))
(if (or (not f) (eq? f not-implemented))
(mrefx x key l)
(apply f x key l))))
(define-syntax-rule (unx mrefx- mref-)
(define-syntax-rule (mref- x key l)
(let ((xx x))
(let ((res (mrefx- xx key l)))
(if (and (not (struct? res)) (procedure? res))
(lambda z
(apply res xx z))
res)))))
(unx mrefx- mref-)
(unx mrefx mref)
(unx mrefx-py mref-py)
(unx mrefx-py- mref-py-)
(define-syntax-rule (unx mrefx- mref-)
(define-syntax-rule (mref- x key l)
(let ((xx x))
(let ((res (mrefx- xx key l)))
(if (and (not (struct? res))
(not (pyclass? res))
(procedure? res))
(lambda z
(apply res xx z))
res)))))
(unx mrefx- mref-q)
(unx mrefx mrefq)
(unx mrefx-py mref-pyq)
(unx mrefx-py- mref-py-q)
(define-method (ref (x ) key . l) (mref- x key l))
(define-method (ref (x ) key . l) (mref-q x key l))
(define-method (refq (x ) key val) (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
(define-syntax-rule (mk-arith + +x __add__ __radd__)
(begin
(define-method (+ (x ) y)
(call x '__add__ y))
(define-method (+ x (y ))
(call y '__radd__ x))
(define-method (+ (x ) y)
(call x '__radd__ y))))
;; A few arithmetic operations at service
(mk-arith + +x __add__ __radd__)
(mk-arith - -x __sub__ __rsub__)
(mk-arith * *x __mul__ __rmul__)
;; 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 '__name__ 'name)
(set class '__class__ #f)
(set class '__goops__ name)
(set class '__parents__ (filter-parents (list sups (... ...))))
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 ) (not (ref x '__class__))))