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