pickle
[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 name-object-deep)
10 #:export (reduce cp red cpit))
11
12 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
13
14 (define (vhash->assoc v)
15 (let ((t (make-hash-table)))
16 (vhash-fold
17 (lambda (k v s)
18 (if (hash-ref t k)
19 s
20 (begin
21 (hash-set! t k #t)
22 (cons (cons k v) s))))
23 '() v)))
24
25 (define-method (pcopyable? (o <p>)) #t)
26 (define-method (deep-pcopyable? (o <p>)) #t)
27
28 (define (cp o)
29 (match (red o)
30 ((#:reduce mk f)
31 (let ((oo (mk)))
32 (for-each (lambda (x) (apply (car x) oo (cdr x))) f)
33 oo))))
34
35 (define (red o)
36 (fluid-set! first #t)
37 (list #:reduce
38 (let ((cl (class-of o)))
39 (lambda () (make cl)))
40 (reduce o)))
41
42
43 (define-method (pcopy (o <p>))
44 (list #:obj
45 (aif it (ref o '__copy__)
46 (it)
47 (cp o))))
48
49 (define-method (deep-pcopy (o <p>) p?)
50 (aif it (and p? (ref o '__deepcopy__))
51 (list #:obj (it))
52 (red o)))
53
54 (define first (make-fluid #f))
55 (define-method (reduce o) '())
56 (define-method (reduce (o <p>))
57 (if (fluid-ref first)
58 (begin
59 (fluid-set! first #f)
60 (cons
61 (aif it (ref o '__reduce__)
62 (it)
63 (cons
64 (lambda (o args)
65 (let ((h (make-hash-table)))
66 (slot-set! o 'h h)
67 (for-each
68 (lambda (x) (hash-set! h (car x) (cdr x)))
69 args)))
70 (list
71 (hash-fold
72 (lambda (k v s) (cons (cons k v) s))
73 '()
74 (slot-ref o 'h)))))
75 (next-method)))
76 (next-method)))
77
78 (define (fold f s l)
79 (if (pair? l)
80 (fold f (f (car l) s) (cdr l))
81 s))
82
83 (define-method (reduce (o <pf>))
84 (if (fluid-ref first)
85 (begin
86 (fluid-set! first #f)
87 (cons*
88 (cons
89 (lambda (o n args)
90 (slot-set! o 'size n)
91 (slot-set! o 'n n)
92 (let ((h
93 (fold
94 (lambda (k v s) (vhash-assoc k v s))
95 vlist-null
96 args)))
97 (slot-set! o 'h h)))
98 (list (slot-ref o 'n) (vhash->assoc (slot-ref o 'h))))
99 (next-method)))
100 (next-method)))
101
102 (define-syntax cpit
103 (lambda (x)
104 (syntax-case x ()
105 ((_ <c> (o lam a))
106 #'(begin
107 (define-method (pcopyable? (o <c>) ) #t)
108 (define-method (deep-pcopyable? (o <c>) ) #t)
109 (define-method (pcopy (o <c>) ) (cp o))
110 (define-method (deep-pcopy (o <c>) p?) (red o))
111 (define-method (reduce (o <c>) )
112 (cons*
113 (cons lam a)
114 (next-method))))))))
115
116
117
118