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