cf0f7c29f6cb63d9b46683ec2620722c0ac6a5b4
[software/python-on-guile.git] / modules / language / python / persist.scm
1 (define-module (language python persist)
2 #:use-module (ice-9 match)
3 #:use-module (ice-9 vlist)
4 #:use-module (ice-9 pretty-print)
5 #:use-module (oop goops)
6 #:use-module (oop pf-objects)
7 #:use-module (logic guile-log persistance)
8 #:re-export(pcopyable? deep-pcopyable? pcopy deep-pcopy name-object)
9 #:export (reduce cp red cpit))
10
11 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
12
13 (define (vhash->assoc v)
14 (let ((t (make-hash-table)))
15 (vhash-fold
16 (lambda (k v s)
17 (if (hash-ref t k)
18 s
19 (begin
20 (hash-set! t k #t)
21 (cons (cons k v) s))))
22 '() v)))
23
24 (define-method (pcopyable? (o <p>)) #t)
25 (define-method (deep-pcopyable? (o <p>)) #t)
26
27 (define (cp o)
28 (match (red o)
29 ((#:reduce mk f)
30 (let ((oo (mk)))
31 (for-each (lambda (x) (apply (car x) oo (cdr x))) f)
32 oo))))
33
34 (define (red o)
35 (list #:reduce
36 (let ((cl (class-of o)))
37 (lambda () (make cl)))
38 (reduce o)))
39
40 (define-method (pcopy (o <p>))
41 (list #:obj
42 (aif it (ref o '__copy__)
43 (it)
44 (cp o))))
45
46 (define-method (deep-pcopy (o <p>) p?)
47 (aif it (and p? (ref o '__deepcopy__))
48 (list #:obj (it))
49 (red o)))
50
51 (define-method (reduce o) '())
52 (define-method (reduce (o <p>))
53 (cons*
54 (cons
55 (lambda (o args)
56 (let ((h (make-hash-table)))
57 (slot-set! o 'h h)
58 (for-each
59 (lambda (x) (hash-set! h (car x) (cdr x)))
60 args)))
61 (list
62 (hash-fold
63 (lambda (k v s) (cons (cons k v) s))
64 '()
65 (slot-ref o 'h))))
66 (next-method)))
67
68 (define (fold f s l)
69 (if (pair? l)
70 (fold f (f (car l) s) (cdr l))
71 s))
72
73 (define-method (reduce (o <pf>))
74 (cons*
75 (cons
76 (lambda (o n args)
77 (slot-set! o 'size n)
78 (slot-set! o 'n n)
79 (let ((h
80 (fold
81 (lambda (k v s) (vhash-assoc k v s))
82 vlist-null
83 args)))
84 (slot-set! o 'h h)))
85 (list (slot-ref o 'n) (vhash->assoc (slot-ref o 'h))))
86 (next-method)))
87
88
89
90 (define-syntax cpit
91 (lambda (x)
92 (syntax-case x ()
93 ((_ <c> (o lam a))
94 #'(begin
95 (define-method (pcopyable? (o <c>) ) #t)
96 (define-method (deep-pcopyable? (o <c>) ) #t)
97 (define-method (pcopy (o <c>) ) (cp o))
98 (define-method (deep-pcopy (o <c>) p?) (red o))
99 (define-method (reduce (o <c>) )
100 (cons*
101 (cons lam a)
102 (next-method))))))))
103
104
105
106