reverse forms implemented
[software/python-on-guile.git] / modules / language / python / module.scm
1 (define-module (language python module)
2 #:use-module (oop pf-objects)
3 #:use-module (oop goops)
4 #:use-module (ice-9 match)
5 #:use-module (system syntax)
6 #:use-module (language python exceptions)
7 #:use-module (language python yield)
8 #:use-module (language python try)
9 #:use-module (language python dir)
10 #:use-module (language python list)
11 #:export (Module private public import))
12
13 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
14
15 (define-syntax-rule (in-scheme x)
16 (let ((lan (current-language)))
17 (dynamic-wind
18 (lambda () (current-language 'scheme))
19 (lambda () x)
20 (lambda () (current-language lan)))))
21
22 (define (private mod)
23 ((ref mod '__setprivate__) #t))
24 (define (public mod)
25 ((ref mod '__setprivate__) #f))
26
27 (define e (list 'e))
28
29 (define _k
30 (lambda (k)
31 (if (string? k)
32 (string->symbol k)
33 k)))
34
35 (define _m
36 (lambda (self)
37 (if (rawref self '_private)
38 (rawref self '_module)
39 (rawref self '_export))))
40
41 (define-python-class Module ()
42 (define _modules (make-hash-table))
43 (define __setprivate__
44 (lambda (self p)
45 (rawset self '_isprivate p)))
46
47 (define _cont
48 (lambda (self id pre l nm skip-error?)
49 (if id
50 (aif it (rawref self id)
51 ((ref it '__init__) pre l nm)
52 (begin
53 (rawset self id (Module pre l nm))
54 (_make self pre nm skip-error?)))
55 (_make self pre nm skip-error?))))
56
57 (define _contupdate
58 (lambda (self id pre l nm)
59 (if id
60 (aif it (rawref self id)
61 ((ref it '__update__) pre l nm)
62 (rawset self id (Module pre l nm)))
63 #f)))
64
65 (define __init__
66 (case-lambda
67 ((self pre l nm)
68 (match l
69 ((name)
70 (rawset self '_path (reverse (cons name pre)))
71 (_cont self #f (cons name pre) #f (cons name nm) #f))
72
73 ((name . (and l (name2 . _)))
74 (rawset self '_path (reverse (cons name pre)))
75 (_cont self name2 (cons name pre) l (cons name nm) #t))))
76
77
78 ((self l nm)
79 (_cont self #f l #f nm #f))
80
81 ((self l)
82 (if (pair? l)
83 (if (and (> (length l) 3)
84 (equal? (list (list-ref l 0)
85 (list-ref l 1)
86 (list-ref l 2))
87 '(language python module)))
88 (__init__ self (reverse '(language python module)) (cdddr l) '())
89 #f)
90 (__init__ self
91 (map string->symbol
92 (string-split l #\.)))))))
93 (define __update__
94 (case-lambda
95 ((self pre l nm)
96 (match l
97 ((name)
98 (_contupdate self #f (cons name pre) #f (cons name nm)))
99
100 ((name . (and l (name2 . _)))
101 (_contupdate self name2 (cons name pre) l (cons name nm)))))
102
103
104 ((self l nm)
105 (_contupdate self #f l #f nm))
106
107 ((self l)
108 (if (pair? l)
109 (if (and (> (length l) 3)
110 (equal? (list (list-ref l 0)
111 (list-ref l 1)
112 (list-ref l 2))
113 '(language python module)))
114 (__update__ self (reverse '(language python module))
115 (cdddr l) '()))
116 (__update__ self
117 (map string->symbol
118 (string-split l #\.)))))))
119
120 (define _make
121 (lambda (self l nm skip-error?)
122 (rawset self '_private #f)
123 (if (not (rawref self '_module))
124 (begin
125 (rawset self '__name__ (string-join
126 (map symbol->string (reverse nm)) "."))
127 (let* ((_module (in-scheme (resolve-module (reverse l))))
128 (public-i (and _module (module-public-interface _module))))
129 (if (and (not skip-error?) (not public-i))
130 (raise (ModuleNotFoundError
131 (format #f "No module named ~a"
132 (ref self '__name__)))))
133
134 (rawset self '_export (module-public-interface _module))
135 (rawset self '_module _module)
136 (hash-set! _modules l self))))))
137
138 (define __getattribute__
139 (lambda (self k)
140 (define (fail)
141 (raise (AttributeError "getattr in Module")))
142 (let ((k (_k k))
143 (m (_m self)))
144 (let ((x (module-ref m k e)))
145 (if (eq? e x)
146 (fail)
147 x)))))
148
149 (define __setattr__
150 (lambda (self k v)
151 (let ((k (_k k))
152 (fail (lambda () (raise KeyError "setattr in Module" k))))
153 (if (rawref self k)
154 (fail)
155 (aif m (rawref self '_module)
156 (catch #t
157 (lambda ()
158 (if (module-defined? m k)
159 (module-set! m k v)
160 (module-define! m k v)))
161 (lambda x (fail)))
162 (fail))))))
163
164 (define __delattr__
165 (lambda (self k)
166 (define (fail) (raise KeyError "delattr in Module"))
167 (aif m (rawref self '_module)
168 (let ((k (_k k)))
169 (if (module-defined? m k)
170 (module-remove! m k)
171 (raise KeyError "delattr of missing key in Module")))
172 (fail))))
173
174 (define __dir__
175 (lambda (self)
176 (let* ((h (slot-ref self 'h))
177 (l '())
178 (m (_m self))
179 (add (lambda (k . u) (set! l (cons (symbol->string k) l)))))
180 (hash-for-each add h)
181 (module-for-each add m)
182 (py-list l))))
183
184
185 (define __repr__
186 (lambda (self) (format #f "Module(~a)" (ref self '__name__))))
187
188 (define __getitem__
189 (lambda (self k)
190 (define k (if (string? k) (string->symbol k) k))
191 (__getattribute__ self k)))
192
193 (define __iter__
194 (lambda (self)
195 (define m (_m self))
196 ((make-generator ()
197 (lambda (yield)
198 (define l '())
199 (define (f k v) (set! l (cons (list (symbol->string k) v) l)))
200 (module-for-each f m)
201 (let lp ((l l))
202 (if (pair? l)
203 (begin
204 (apply yield (car l))
205 (lp (cdr l)))))))))))
206
207
208
209 (define-syntax import
210 (lambda (x)
211 (syntax-case x ()
212 ((_ (a ...) var)
213 #`(import-f #,(case (syntax-local-binding #'var)
214 ((lexical)
215 #'var)
216 ((global)
217 #'(if (module-defined? (current-module)
218 (syntax->datum #'var))
219 var
220 #f))
221 (else
222 #f)) a ...)))))
223
224 (define (m? x) ((@ (language python module python) isinstance) x Module))
225 (define (import-f x f . l)
226 (if x
227 (if (m? x)
228 (begin (apply (rawref x '__update__) l) x)
229 (apply f l))
230 (apply f l)))