small steps
[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 (set 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 (set 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 (set 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 (set self '_export (module-public-interface _module))
135 (set self '_module _module)
136 (hash-set! _modules l self))))))
137
138 (define __getattr__
139 (lambda (self k)
140 (define (fail)
141 (raise (AttributeError "getattr in Module")))
142 (if (rawref self '_module)
143 (let ((k (_k k))
144 (m (_m self)))
145 (let ((x (module-ref m k e)))
146 (if (eq? e x)
147 (fail)
148 x)))
149 (fail))))
150
151 (define __setattr__
152 (lambda (self k v)
153 (let ((k (_k k))
154 (fail (lambda () (raise KeyError "getattr in Module" k))))
155 (if (rawref self k)
156 (fail)
157 (aif m (rawref self '_module)
158 (catch #t
159 (lambda ()
160 (if (module-defined? m k)
161 (module-set! m k v)
162 (module-define! m k v)))
163 (lambda x (fail)))
164 (fail))))))
165
166 (define __delattr__
167 (lambda (self k)
168 (define (fail) (raise KeyError "getattr in Module"))
169 (aif m (rawref self '_module)
170 (let ((k (_k k)))
171 (if (module-defined? m k)
172 (module-remove! m k)
173 (raise KeyError "delattr of missing key in Module")))
174 (fail))))
175
176 (define __dir__
177 (lambda (self)
178 (let* ((h (slot-ref self 'h))
179 (l '())
180 (add (lambda (k . u) (set! l (cons (symbol->string k) l)))))
181 (hash-for-each add h)
182 (aif it (ref self '_module)
183 (module-for-each add it)
184 #f)
185 (py-list l))))
186
187
188 (define __repr__
189 (lambda (self) (format #f "Module(~a)" (ref self '__name__))))
190
191 (define __getitem__
192 (lambda (self k)
193 (define k (if (string? k) (string->symbol k) k))
194 (__getattr__ self k)))
195
196 (define __iter__
197 (lambda (self)
198 (define m (_m self))
199 ((make-generator ()
200 (lambda (yield)
201 (define l '())
202 (define (f k v) (set! l (cons (list (symbol->string k) v) l)))
203 (module-for-each f m)
204 (let lp ((l l))
205 (if (pair? l)
206 (begin
207 (apply yield (car l))
208 (lp (cdr l)))))))))))
209
210
211
212 (define-syntax import
213 (lambda (x)
214 (syntax-case x ()
215 ((_ (a ...) var)
216 #`(import-f #,(case (syntax-local-binding #'var)
217 ((lexical)
218 #'var)
219 ((global)
220 #'(if (module-defined? (current-module)
221 (syntax->datum #'var))
222 var
223 #f))
224 (else
225 #f)) a ...)))))
226
227 (define (m? x) ((@ (language python module python) isinstance) x Module))
228 (define (import-f x f . l)
229 (if x
230 (if (m? x)
231 (begin (apply (rawref x '__update__) l) x)
232 (apply f l))
233 (apply f l)))