c036144c3c2fe7abb7fdbca60e772c3edea01cb4
[software/python-on-guile.git] / modules / oop / pf-objects.scm
1 (define-module (oop pf-objects)
2 #:use-module (oop goops)
3 #:use-module (ice-9 vlist)
4 #:use-module (ice-9 match)
5 #:export (set ref make-pf <p> <py> <pf> <pyf>
6 call with copy fset fcall make-p put put!
7 pcall pcall! get fset-x
8 mk wrap
9 def-pf-class mk-pf-class make-pf-class
10 def-p-class mk-p-class make-p-class
11 def-pyf-class mk-pyf-class make-pyf-class
12 def-py-class mk-py-class make-py-class
13 define-python-class
14 ))
15 #|
16 Python object system is basically syntactic suger otop of a hashmap and one
17 this project is inspired by the python object system and what it measn when
18 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
19 with assocs or tree like functional hashmaps in stead.
20
21 The hashmap works like an assoc e.g. we will define new values by 'consing' a
22 new binding on the list and when the assoc take up too much space it will be
23 reshaped and all extra bindings will be removed.
24
25 The datastructure is functional but the objects mutate. So one need to
26 explicitly tell it to not update etc.
27 |#
28
29 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
30
31 (define-class <p> () h)
32 (define-class <pf> (<p>) size n) ; the pf object consist of a functional
33 ; hashmap it's size and number of live
34 ; object
35 (define-class <py> (<p>))
36 (define-class <pyf> (<pf>))
37
38 ;; Make an empty pf object
39 (define (make-pf)
40 (define r (make <pf>))
41 (slot-set! r 'h vlist-null)
42 (slot-set! r 'size 0)
43 (slot-set! r 'n 0)
44 r)
45
46 (define (make-p)
47 (define r (make <p>))
48 (slot-set! r 'h (make-hash-table))
49 r)
50
51 (define-syntax-rule (hif it (k h) x y)
52 (let ((a (vhash-assq k h)))
53 (if (pair? a)
54 (let ((it (cdr a)))
55 x)
56 y)))
57
58 (define-syntax-rule (cif (it h) (k cl) x y)
59 (let* ((h (slot-ref cl 'h))
60 (a (vhash-assq k h)))
61 (if (pair? a)
62 (let ((it (cdr a)))
63 x)
64 y)))
65
66 (define fail (cons 'fail '()))
67 (define-syntax-rule (mrefx x key l)
68 (let ()
69 (define (end)
70 (if (null? l)
71 #f
72 (car l)))
73
74 (define (parents li)
75 (let lp ((li li))
76 (if (pair? li)
77 (let ((p (car li)))
78 (cif (it h) (key p)
79 it
80 (hif it ('__parents__ h)
81 (let ((r (parents it)))
82 (if (eq? r fail)
83 (lp (cdr li))
84 r))
85 (lp (cdr li)))))
86 fail)))
87
88 (cif (it h) (key x)
89 it
90 (hif cl ('__class__ h)
91 (cif (it h) (key cl)
92 it
93 (hif p ('__parents__ h)
94 (let ((r (parents p)))
95 (if (eq? r fail)
96 (end)
97 r))
98 (end)))
99 (end)))))
100
101 (define-syntax-rule (mrefx- x key l) (mrefx-- (slot-ref x 'h) key l))
102 (define-syntax-rule (mrefx-- hi key l)
103 (let ()
104 (define (end) (if (pair? l) (car l) #f))
105 (define (ret q) (if (eq? q fail) (end) q))
106
107 (define (find-in-class h)
108 (let lp ((class-h h))
109 (let ((r (hash-ref class-h key fail)))
110 (if (eq? r fail)
111 (aif parents (hash-ref class-h '__parents__ #f)
112 (let lpp ((parents parents))
113 (if (pair? parents)
114 (let ((parent (car parents)))
115 (let ((r (lp (slot-ref parent 'h))))
116 (if (eq? r fail)
117 (lpp (cdr parents))
118 r)))
119 fail))
120 fail)
121 r))))
122
123 (let* ((h hi)
124 (r (hash-ref h key fail)))
125 (if (eq? r fail)
126 (aif class (hash-ref h '__class__)
127 (ret (find-in-class (slot-ref class 'h)))
128 fail)
129 r))))
130
131 (define not-implemented (cons 'not 'implemeneted))
132
133 (define-syntax-rule (mrefx-py- x key l)
134 (let ((f (mrefx- x '__ref__ '())))
135 (if (or (not f) (eq? f not-implemented))
136 (mrefx- x key l)
137 (apply f x key l))))
138
139 (define-syntax-rule (mrefx-py x key l)
140 (let ((f (mrefx x '__ref__ '())))
141 (if (or (not f) (eq? f not-implemented))
142 (mrefx x key l)
143 (apply f x key l))))
144
145 (define-syntax-rule (unx mrefx- mref-)
146 (define-syntax-rule (mref- x key l)
147 (let ((xx x))
148 (let ((res (mrefx- xx key l)))
149 (if (procedure? res)
150 (lambda z
151 (apply res xx z))
152 res)))))
153
154 (unx mrefx- mref-)
155 (unx mrefx mref)
156 (unx mrefx-py mref-py)
157 (unx mrefx-py- mref-py-)
158
159 (define-method (ref (x <pf> ) key . l) (mref x key l))
160 (define-method (ref (x <p> ) key . l) (mref- x key l))
161 (define-method (ref (x <pyf>) key . l) (mref-py x key l))
162 (define-method (ref (x <py> ) key . l) (mref-py- x key l))
163 (define-method (ref x key . l)
164 (define (end) (if (pair? l) (car l) #f))
165 (if (procedure? x)
166 (aif it (procedure-property x 'pyclass)
167 (apply ref it key l)
168 (end))
169 (end)))
170
171
172
173 ;; the reshape function that will create a fresh new pf object with less size
174 ;; this is an expensive operation and will only be done when we now there is
175 ;; a lot to gain essentially tho complexity is as in the number of set
176 (define (reshape x)
177 (let ((h (slot-ref x 'h))
178 (m (make-hash-table))
179 (n 0))
180 (define h2 (vhash-fold (lambda (k v s)
181 (if (hash-ref m k #f)
182 s
183 (begin
184 (hash-set! m k #t)
185 (set! n (+ n 1))
186 (vhash-consq k v s))))
187 vlist-null
188 h))
189 (slot-set! x 'h h2)
190 (slot-set! x 'size n)
191 (slot-set! x 'n n)
192 (values)))
193
194 ;; on object x add a binding that key -> val
195 (define-syntax-rule (mset x key val)
196 (let ((h (slot-ref x 'h))
197 (s (slot-ref x 'size))
198 (n (slot-ref x 'n)))
199 (slot-set! x 'size (+ 1 s))
200 (let ((r (vhash-assq key h)))
201 (when (not r)
202 (slot-set! x 'n (+ n 1)))
203 (slot-set! x 'h (vhash-consq key val h))
204 (when (> s (* 2 n))
205 (reshape x))
206 (values))))
207
208 (define-syntax-rule (mset-py x key val)
209 (let ((f (mref-py x '__set__ '())))
210 (if (or (eq? f not-implemented) (not f))
211 (mset x key val)
212 (f key val))))
213
214 (define (pkh h) (hash-for-each (lambda x (pk x)) h) h)
215
216 (define-syntax-rule (mset- x key val)
217 (let ()
218 (define (s h) (begin (hash-set! h key val) #f))
219 (define fret #t)
220 (define (r h k) (hash-ref h k))
221 (define-syntax-rule (ifh h fail-code)
222 (if (r h key)
223 (s h)
224 fail-code))
225
226 (define (hm x) (slot-ref x 'h))
227 (let ((h (hm x)))
228 (if (ifh h
229 (aif it (r h '__class__)
230 (let lp ((cl it))
231 (let ((h (hm cl)))
232 (ifh h
233 (aif it (r h '__parents__)
234 (let lp2 ((parents it))
235 (if (pair? parents)
236 (if (lp (car parents))
237 (lp2 (cdr parents))
238 fret)
239 fret))
240 fret))))
241 fret))
242 (s h))
243 (values))))
244
245 (define-syntax-rule (mset-py- x key val)
246 (let ((f (mref-py- x '__set__ '())))
247 (if (or (eq? f not-implemented) (not f))
248 (mset- x key val)
249 (f key val))))
250
251 (define-method (set (x <pf>) key val) (mset x key val))
252 (define-method (set (x <p>) key val) (mset- x key val))
253 (define-method (set (x <pyf>) key val) (mset-py x key val))
254 (define-method (set (x <py>) key val) (mset-py- x key val))
255
256 ;; mref will reference the value of the key in the object x, an extra default
257 ;; parameter will tell what the fail object is else #f if fail
258 ;; if there is no found binding in the object search the class and
259 ;; the super classes for a binding
260
261 ;; call a function as a value of key in x with the object otself as a first
262 ;; parameter, this is pythonic object semantics
263 (define-syntax-rule (mk-call mcall mref)
264 (define-syntax-rule (mcall x key l)
265 (apply (mref x key '()) l)))
266
267 (mk-call mcall mref)
268 (mk-call mcall- mref-)
269 (mk-call mcall-py mref-py)
270 (mk-call mcall-py- mref-py-)
271
272 (define-method (call (x <pf>) key . l) (mcall x key l))
273 (define-method (call (x <p>) key . l) (mcall- x key l))
274 (define-method (call (x <pyf>) key . l) (mcall-py x key l))
275 (define-method (call (x <py>) key . l) (mcall-py- x key l))
276
277
278 ;; make a copy of a pf object
279 (define-syntax-rule (mcopy x)
280 (let ((r (make <pf>)))
281 (slot-set! r 'h (slot-ref x 'h))
282 (slot-set! r 'size (slot-ref x 'size))
283 (slot-set! r 'n (slot-ref x 'n))
284 r))
285
286 (define-syntax-rule (mcopy- x)
287 (let* ((r (make-p))
288 (h (slot-ref r 'h)))
289 (hash-for-each (lambda (k v) (hash-set! h k v)) (slot-ref x 'h))
290 r))
291
292 (define-method (copy (x <pf>)) (mcopy x))
293 (define-method (copy (x <p> )) (mcopy- x))
294
295
296 ;; with will execute thunk and restor x to it's initial state after it has
297 ;; finished note that this is a cheap operatoin because we use a functional
298 ;; datastructure
299 (define-syntax-rule (mwith x thunk)
300 (let ((old (mcopy x)))
301 (let ((r (thunk)))
302 (slot-set! x 'h (slot-ref old 'h))
303 (slot-set! x 'size (slot-ref old 'size))
304 (slot-set! x 'n (slot-ref old 'n))
305 r)))
306
307 (define-syntax-rule (mwith- x thunk)
308 (let ((old (mcopy- x)))
309 (let ((r (thunk)))
310 (slot-set! x 'h (slot-ref old 'h))
311 r)))
312
313
314
315 ;; a functional set will return a new object with the added binding and keep
316 ;; x untouched
317 (define-method (fset (x <pf>) key val)
318 (let ((x (mcopy x)))
319 (mset x key val)
320 x))
321
322 (define-method (fset (x <p>) key val)
323 (let ((x (mcopy- x)))
324 (mset x key val)
325 x))
326
327 (define (fset-x obj l val)
328 (let lp ((obj obj) (l l) (r '()))
329 (match l
330 (()
331 (let lp ((v val) (r r))
332 (if (pair? r)
333 (lp (fset (caar r) (cdar r) v) (cdr r))
334 v)))
335 ((k . l)
336 (lp (ref obj k #f) l (cons (cons obj k) r))))))
337
338
339
340
341
342 ;; a functional call will keep x untouched and return (values fknval newx)
343 ;; e.g. we get both the value of the call and the new version of x with
344 ;; perhaps new bindings added
345 (define-method (fcall (x <pf>) key . l)
346 (let* ((y (mcopy x))
347 (r (mcall y key l)))
348 (if (eq? (slot-ref x 'h) (slot-ref y 'h))
349 (values r x)
350 (values r y))))
351
352 (define-method (fcall (x <p>) key . l)
353 (let ((x (mcopy x)))
354 (values (mcall- x key l)
355 x)))
356
357 ;; this shows how we can override addition in a pythonic way
358 (define-syntax-rule (mk-arith + +x __add__ __radd__)
359 (begin
360 (define-method (+ (x <p>) y)
361 (call x '__add__ y))
362
363 (define-method (+ x (y <p>))
364 (call y '__radd__ x))
365
366 (define-method (+ (x <py>) y)
367 (let ((f (mref-py- x '__add__ '())))
368 (if f
369 (f y)
370 (+x y x))))
371
372 (define-method (+ (x <pyf>) y)
373 (let ((f (mref-py x '__add__ '())))
374 (if f
375 (let ((res (f y)))
376 (if (eq? res not-implemented)
377 (+x y x)
378 res))
379 (+x y x))))
380
381 (define-method (+ (x <py>) y)
382 (let ((f (mref-py- x '__add__ '())))
383 (if f
384 (let ((res (f y)))
385 (if (eq? res not-implemented)
386 (+x y x)
387 res))
388 (+x y x))))
389
390 (define-method (+ x (y <py>))
391 (call y '__radd__ x))
392
393 (define-method (+ x (y <pyf>))
394 (call y '__radd__ x))
395
396 (define-method (+x (x <p>) y)
397 (call x '__radd__ y))))
398
399 ;; A few arithmetic operations at service
400 (mk-arith + +x __add__ __radd__)
401 (mk-arith - -x __sub__ __rsub__)
402 (mk-arith * *x __mul__ __rmul__)
403
404 ;; lets define get put pcall etc so that we can refer to an object like
405 ;; e.g. (put x.y.z 1) (pcall x.y 1)
406
407 (define-syntax-rule (cross x k f set)
408 (call-with-values (lambda () f)
409 (lambda (r y)
410 (if (eq? x y)
411 (values r x)
412 (values r (set x k y))))))
413
414 (define-syntax-rule (cross! x k f _) f)
415
416 (define-syntax mku
417 (syntax-rules ()
418 ((_ cross set setx f (key) (val ...))
419 (setx f key val ...))
420 ((_ cross set setx f (k . l) val)
421 (cross f k (mku cross set setx (ref f k) l val) set))))
422
423 (define-syntax-rule (mkk pset setx set cross)
424 (define-syntax pset
425 (lambda (x)
426 (syntax-case x ()
427 ((_ f val (... ...))
428 (let* ((to (lambda (x)
429 (datum->syntax #'f (string->symbol x))))
430 (l (string-split (symbol->string (syntax->datum #'f)) #\.)))
431 (with-syntax (((a (... ...)) (map (lambda (x) #`'#,(to x))
432 (cdr l)))
433 (h (to (car l))))
434 #'(mku cross setx set h (a (... ...)) (val (... ...))))))))))
435
436 (mkk put fset fset cross)
437 (mkk put! set set cross!)
438 (mkk pcall! call fset cross!)
439 (mkk pcall fcall fset cross)
440 (mkk get ref fset cross!)
441
442 ;; it's good to have a null object so we don't need to construct it all the
443 ;; time because it is functional we can get away with this.
444 (define null (make-pf))
445
446 ;; append the bindings in x in front of y + some optimizations
447 (define (union x y)
448 (define hx (slot-ref x 'h))
449 (define hy (slot-ref y 'h))
450 (define n (slot-ref x 'n))
451 (define s (slot-ref x 'size))
452 (define m (make-hash-table))
453
454 (define h
455 (vhash-fold
456 (lambda (k v st)
457 (if (vhash-assq k hy)
458 (begin
459 (set! s (+ s 1))
460 (vhash-consq k v st))
461 (if (hash-ref m k)
462 s
463 (begin
464 (set! n (+ n 1))
465 (set! s (+ s 1))
466 (hash-set! m k #t)
467 (vhash-consq k v st)))))
468 hy
469 hx))
470
471 (define out (make <pf>))
472 (slot-set! out 'h h)
473 (slot-set! out 'n n)
474 (slot-set! out 'size s)
475 out)
476
477 (define (union- x y)
478 (define hx (slot-ref x 'h))
479 (define hy (slot-ref y 'h))
480 (define out (make-p))
481 (define h (slot-ref out 'h))
482 (hash-for-each (lambda (k v) (hash-set! h k v)) hy)
483 (hash-for-each (lambda (k v) (hash-set! h k v)) hx)
484 out)
485
486
487 ;; make a class. A class add some meta information to allow for multiple
488 ;; inherritance and add effectively static data to the object the functional
489 ;; datastructure show it's effeciency now const is data that will not change
490 ;; and bindings that are added to all objects. Dynamic is the mutating class
491 ;; information. supers is a list of priorities
492 (define-syntax-rule (mk-pf make-pf-class <pf>)
493 (define-syntax make-pf-class
494 (lambda (x)
495 (syntax-case x ()
496 ((_ name const dynamic (supers (... ...)))
497 (with-syntax (((sups (... ...)) (generate-temporaries
498 #'(supers (... ...)))))
499 #'(let ((sups supers) (... ...))
500 (define class dynamic)
501 (define name (make-class (list sups (... ...) <pf>) '()))
502
503 (put! class.__const__
504 (union const
505 (let lp ((sup (list sups (... ...))))
506 (if (pair? sup)
507 (union (ref (car sup) '__const__ null)
508 (lp (cdr sup)))
509 null))))
510
511 (reshape (get class.__const__ null))
512
513 (put! class.__goops__ name)
514 (put! class.__name__ 'name)
515 (put! class.__parents__ (list sups (... ...)))
516
517 (put! class.__const__.__name__ (cons 'name 'obj))
518 (put! class.__const__.__class__ class)
519 (put! class.__const__.__parents__ (list sups (... ...)))
520 (put! class.__const__.__goops__ name)
521 class)))))))
522
523 (mk-pf make-pf-class <pf>)
524 (mk-pf make-pyf-class <pyf>)
525
526 (define-syntax-rule (mk-p make-p-class <p>)
527 (define-syntax make-p-class
528 (lambda (x)
529 (syntax-case x ()
530 ((_ name const dynamic (supers (... ...)))
531 (with-syntax (((sups (... ...)) (generate-temporaries
532 #'(supers (... ...)))))
533 #'(let ((sups supers) (... ...))
534 (define class dynamic)
535 (define name (make-class (list (ref sups '__goops__ #f)
536 (... ...) <p>) '()))
537
538 (set! class
539 (union- const
540 (let lp ((sup (list sups (... ...))))
541 (if (pair? sup)
542 (union- (car sup)
543 (lp (cdr sup)))
544 (make-p)))))
545
546
547 (set class '__goops__ name)
548 (set class '__name__ 'name)
549 (set class '__parents__ (list sups (... ...)))
550
551 class)))))))
552
553 (mk-p make-p-class <p>)
554 (mk-p make-py-class <py>)
555
556 ;; Let's make an object essentially just move a reference
557 (define-method (mk (x <pf>) . l)
558 (let ((r (ref x '__const__))
559 (o (make (ref x '__goops__))))
560 (slot-set! o 'h (slot-ref r 'h))
561 (slot-set! o 'size (slot-ref r 'size))
562 (slot-set! o 'n (slot-ref r 'n))
563 (apply (ref o '__init__ (lambda x (error "no init fkn"))) o l)
564 o))
565
566
567 (define-method (mk (x <p>) . l)
568 (let ((o (make (ref x '__goops__)))
569 (h (make-hash-table)))
570 (slot-set! o 'h h)
571 (hash-set! h '__class__ x)
572 (apply (ref o '__init__ (lambda x (error "no init fkn"))) l)
573 o))
574
575 ;; the make class and defclass syntactic sugar
576 (define-syntax-rule (mk-p/f make-pf mk-pf-class make-pf-class)
577 (define-syntax-rule (mk-pf-class name (parents (... ...))
578 #:const
579 ((sdef mname sval) (... ...))
580 #:dynamic
581 ((ddef dname dval) (... ...)))
582 (let ()
583 (define name
584 (make-pf-class name
585 (let ((s (make-pf)))
586 (set s 'mname sval) (... ...)
587 s)
588 (let ((d (make-pf)))
589 (set d 'dname dval) (... ...)
590 d)
591 (parents (... ...))))
592 name)))
593
594 (mk-p/f make-pf mk-pf-class make-pf-class)
595 (mk-p/f make-p mk-p-class make-p-class)
596 (mk-p/f make-pf mk-pyf-class make-pyf-class)
597 (mk-p/f make-p mk-py-class make-py-class)
598
599 (define-syntax-rule (def-pf-class name . l)
600 (define name (mk-pf-class name . l)))
601
602 (define-syntax-rule (def-p-class name . l)
603 (define name (mk-p-class name . l)))
604
605 (define-syntax-rule (def-pyf-class name . l)
606 (define name (mk-pyf-class name . l)))
607
608 (define-syntax-rule (def-py-class name . l)
609 (define name (mk-py-class name . l)))
610
611 (define-syntax-rule (wrap name class)
612 (let* ((c class)
613 (name (lambda x (apply mk c x))))
614 (set-procedure-property! name 'pyclass c)
615 name))
616
617 (define (get-class o)
618 (cond
619 ((procedure? o)
620 (aif it (procedure-property o 'pyclass)
621 it
622 (error "not an object ~a" o)))
623 (else
624 (class-of o))))
625
626 (define (get-type o)
627 (cond
628 ((is-a? o <pyf>)
629 'pyf)
630 ((is-a? o <py>)
631 'py)
632 ((is-a? o <pf>)
633 'pf)
634 ((is-a? o <p>)
635 'p)
636 (else
637 'none)))
638
639 (define (print o l)
640 (define port (if (pair? l) (car l) #t))
641 (format port
642 (aif it (ref o '__repr__)
643 (it)
644 (format #f
645 "~a:~a" (get-type o) (ref o '__name__ 'None)))))
646
647 (define-method (write (o <p>) . l) (print o l))
648 (define-method (display (o <p>) . l) (print o l))
649
650
651
652 (define-syntax-rule (define-python-class name parents code ...)
653 (define name
654 (wrap name
655 (mk-py-class name parents
656 #:const
657 (code ...)
658 #:dynamic
659 ()))))