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