summaryrefslogtreecommitdiff
path: root/modules/language/python/#persist.scm#
blob: 4ee46fc97050d3f4278266da1355fedf578b3010 (about) (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
(define-module (language python persist)
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist)
  #:use-module (ice-9 pretty-print)
  #:use-module (oop goops)
  #:use-module (oop pf-objects)
  #:use-module (logic guile-log persistance)
  #:re-export(pcopyable? deep-pcopyable? pcopy deep-pcopy name-object
			 name-object-deep)
  #:export (reduce cp red cpit))

(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))

(define (vhash->assoc v)
  (let ((t (make-hash-table)))
    (vhash-fold
     (lambda (k v s)
       (if (hash-ref t k)
	   s
	   (begin
	     (hash-set! t k #t)
	     (cons (cons k v) s))))
     '() v)))

(define-method (pcopyable?      (o <p>)) #t)
(define-method (deep-pcopyable? (o <p>)) #t)

(define (cp o)
  (match (red o)
	 ((#:reduce mk f)
	  (let ((oo (mk)))
	    (for-each (lambda (x) (apply (car x) oo (cdr x))) f)
	    oo))))

(define (red o)
  (fluid-set! first #t)
  (list #:reduce
	(let ((cl (class-of o)))
	  (lambda () (make cl)))		
	(reduce o)))
  

(define-method (pcopy (o <p>))
  (list #:obj
	(aif it (ref o '__copy__)
	     (it)
	     (cp o))))

(define-method (deep-pcopy (o <p>) p?)
  (aif it (and p? (ref o '__deepcopy__))
       (list #:obj  (it))
       (red o)))

(define first (make-fluid #f))
(define-method (reduce o) '())
(define-method (reduce (o <p>))
  (if (fluid-ref first)
      (begin
	(fluid-set! first #f)
	(cons
	 (aif it (ref o '__reduce__)
	      (it)
	      (cons
	       (lambda (o args)
		 (let ((h (make-hash-table)))
		   (slot-set! o 'h h)
		   (for-each
		    (lambda (x) (hash-set! h (car x) (cdr x)))
		    args)))
	       (list
		(hash-fold
		 (lambda (k v s) (cons (cons k v) s))
		 '()
		 (slot-ref o 'h)))))
	 (next-method)))
      (next-method)))

(define (fold f s l)
  (if (pair? l)
      (fold f (f (car l) s) (cdr l))
      s))

(define-method (reduce (o <pf>))
  (if (fluid-ref first)
      (begin
	(fluid-set! first #f)
	(cons*
	 (cons
	  (lambda (o n args)
	    (slot-set! o 'size n)
	    (slot-set! o 'n    n)
	    (let ((h
		   (fold	      
		    (lambda (k v s) (vhash-assoc k v s))
		    vlist-null
		    args)))
	      (slot-set! o 'h h)))
	  (list (slot-ref o 'n) (vhash->assoc (slot-ref o 'h))))
	 (next-method)))
      (next-method)))
     
(define-syntax cpit
  (lambda (x)
    (syntax-case x ()
      ((_ <c> (o lam a))
       #'(begin    
	   (define-method (pcopyable?      (o <c>)   ) #t)
	   (define-method (deep-pcopyable? (o <c>)   ) #t)
	   (define-method (pcopy           (o <c>)   ) (cp o))
	   (define-method (deep-pcopy      (o <c>) p?) (red o))
	   (define-method (reduce          (o <c>)   )
	     (cons*
	      (cons lam a)
	      (next-method))))))))