smtp
[software/python-on-guile.git] / modules / language / python / format2.scm
1 (define-module (language python format2)
2 #:use-module (ice-9 match)
3 #:use-module (parser stis-parser)
4 #:use-module (oop pf-objects)
5 #:use-module (oop goops)
6 #:use-module (language python exceptions)
7 #:use-module (language python number)
8 #:use-module (language python dict)
9 #:use-module (language python list)
10 #:export (format fnm))
11
12 (define splitm #f)
13 (define splitmm #f)
14
15 (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
16
17 (define scm-format (@ (guile) format))
18
19 (define e-map (f-seq "(" (mk-token (f* (f-not! (f-tag ")")))) ")"))
20 (define e-conv (mk-token (f+ (f-reg! "[-#0 +]"))))
21 (define e-min (f-or! (mk-token (f+ (f-reg! "[0-9]")) string->number)
22 (f-seq "*" (f-out #:*))))
23 (define e-prec (f-seq "." (f-or!
24 (mk-token (f+ (f-reg! "[0-9]")) string->number)
25 (f-seq "*" (f-out #:*)))))
26 (define e-len (mk-token (f-reg! "[hlL]")))
27 (define e-type (mk-token (f-reg! "[diouxXeEfFgGcrsa%]")))
28 (define e (f-list #:% "%" (ff? e-map) (ff? e-conv) (ff? e-min)
29 (ff? e-prec) (ff? e-len) e-type))
30
31 (define (map? l)
32 (let lp ((l l))
33 (match l
34 ((a (#:% #f . _) . l)
35 (lp l))
36 ((a (#:% _ . _) . l)
37 #t)
38 (_ #f))))
39
40 (define (get-n p)
41 (match p
42 ((#:% _ _ _ _ _ "%")
43 -1)
44
45 ((#:% #f _ #:* #:* . _)
46 2)
47 ((#:% #f _ #:* _ . _)
48 1)
49 ((#:% #f _ _ #:* . _)
50 1)
51 (_
52 0)))
53
54 (define (create c min prec tp)
55 (define (get-intkind tp)
56 (match tp
57 ((or "d" "i" "u")
58 "d")
59 ("o"
60 "o")
61 ((or "x" "X")
62 "x")))
63
64 (let ((prec (if prec prec 6))
65 (min (if min min 0))
66 (c (if c c "")))
67 (match tp
68 ("c"
69 (lambda (x)
70 (if (and (number? x) (integer? x))
71 (list->string (list (integer->char x)))
72 x)))
73
74 ("s" (lambda (x)
75 (let ((s (if (is-a? x <p>)
76 (aif it (ref x '__str__)
77 (scm-format #f "~a" (it))
78 (scm-format #f "~a" x))
79 (scm-format #f "~a" x))))
80 (+ s (* " " (max 0 (- min (len s))))))))
81
82 ("a" (lambda (x)
83 (let ((s (scm-format #f "~a" x)))
84 (+ s (* " " (max 0 (- min (len s))))))))
85
86 ("r" (lambda (x)
87 (let ((s (scm-format #f "~a" x)))
88 (+ s (* " " (max 0 (- min (len s))))))))
89
90 ("%"
91 (lambda (x) (* "%" (if min min 1))))
92 ((or "f" "F" "e" "E" "g" "G")
93 (let ((c (string->list c)))
94 (define (make-decimal)
95 (string-append
96 "~"
97 (if min (number->string min) "")
98 ","
99 (number->string prec)
100 ",,,"
101 (if (member #\0 c)
102 "0"
103 (if (member #\space c)
104 " "
105 ""))
106 (if (member #\+ c) "@" "")
107 "f"))
108 (define (make-exp expchar)
109 (string-append
110 "~"
111 (if min (number->string min) "")
112 ","
113 (number->string prec)
114 ",,,,"
115 (if (member #\0 c)
116 "0"
117 (if (member #\space c)
118 " "
119 ""))
120 ",'"
121 expchar
122 (if (member #\+ c) "@" "")
123 "e"))
124 (match tp
125 ((or "f" "F")
126 (let ((pat (make-decimal)))
127 (lambda (x) (scm-format #f pat x))))
128 ((or "e" "E")
129 (let ((pat (make-exp tp)))
130 (lambda (x) (scm-format #f pat x))))
131 ((or "g" "G")
132 (let ((pat1 (make-decimal))
133 (pat2 (make-exp (if (equal? tp "g") "e" "E"))))
134 (lambda (x)
135 (if (or (< (log10 (abs x)) -4)
136 (if prec (< (log10 (abs x)) (- prec)) #f))
137 (scm-format #f pat2 x)
138 (scm-format #f pat1 x))))))))
139
140
141 ((or "d" "i" "u" "o" "x" "X")
142 (match c
143 (""
144 (let ((kind (get-intkind tp)))
145 (if min
146 (let ((pat (string-append "~"
147 (number->string min) ",' " kind)))
148 (lambda (x)
149 (scm-format #f pat x)))
150 (let ((pat (string-append "~" kind)))
151 (lambda (x)
152 (scm-format #f pat x))))))
153 (_
154 (if min
155 (let ((c (string->list c)))
156 (if (and (member #\# c)
157 (match tp
158 ((or "x" "o" "X") #t)
159 (_ #f)))
160 (set! c (cons #\0 c)))
161 (let* ((kind (get-intkind tp))
162 (padchar (if (member #\0 c) "0" " "))
163 (pre (if (member #\+ c)
164 "~a"
165 (if (member #\0 c)
166 "~a"
167 (if (member #\space c)
168 "~a"
169 ""))))
170 (pos (if (member #\+ c) "+"
171 (if (member #\space c)
172 " "
173 padchar)))
174 (kpre (if (member #\# c)
175 (match tp
176 ("o" "0o")
177 ((or "x" "X") "0x")
178 (_ ""))
179 ""))
180
181 (neg (if (or (member #\+ c)
182 (member #\space c)
183 (member #\0 c))
184 "-"
185 ""))
186 (d (string-append
187 pre kpre "~"
188 (number->string
189 (- min
190 (if (= (string-length kpre) 0) 0 2)
191 (if (= (string-length pre ) 0) 0 1)))
192 ",'"
193 padchar
194 kind)))
195 (if (= (string-length pre) 0)
196 (lambda (x)
197 (if (and (number? x) (integer? x))
198 (scm-format #f d x)
199 (raise
200 (ValueError "not a integer, format spec %d"))))
201 (lambda (x)
202 (if (and (number? x) (integer? x))
203 (scm-format #f d (if (< x 0) neg pos) (abs x))
204 (raise
205 (ValueError
206 "not a integer, format spec %d")))))))
207 (let* ((kind (get-intkind tp))
208 (pat (string-append "~" kind)))
209 (lambda (x)
210 (if (and (number? x) (integer? x))
211 (scm-format #f pat x)
212 (raise
213 (ValueError "not a integer, format spec %d"))))))))))))
214
215
216 (define (analyze p)
217 (match p
218 ((#:% #f c #:* #:* _ tp)
219 (lambda (min prec x)
220 ((create c min prec tp) x)))
221 ((#:% #f c #:* prec _ tp)
222 (lambda (min x)
223 ((create c min prec tp) x)))
224 ((#:% #f c #:* prec _ tp)
225 (lambda (min x)
226 ((create c min prec tp) x)))
227 ((#:% #f c min #:* _ tp)
228 (lambda (prec x)
229 ((create c min prec tp) x)))
230
231 ((#:% #f c min prec _ tp)
232 (create c min prec tp))
233 ((#:% tag c min prec _ tp)
234 (let ((f (create c min prec tp)))
235 (lambda (x)
236 (f (pylist-ref x tag)))))))
237
238
239 (define (compile str)
240 (let* ((l (splitmm e str)))
241 (if (map? l)
242 (let lp ((l l))
243 (match l
244 ((a p . l)
245 (let ((rest (lp l))
246 (f (analyze p)))
247 (lambda (x)
248 (cons* a (f x) (rest x)))))
249 ((a)
250 (lambda (x)
251 (list a)))
252 (()
253 (lambda (x)
254 '()))))
255
256 (let lp ((l l))
257 (match l
258 ((a p . l)
259 (let ((rest (lp l))
260 (n (get-n p))
261 (f (analyze p)))
262 (case n
263 ((-1)
264 (lambda (x)
265 (cons* a "%" (rest x))))
266
267 ((0)
268 (lambda (x)
269 (cons* a (f (car x)) (rest (cdr x)))))
270 ((1)
271 (lambda (x)
272 (cons* a (f (car x) (cadr x)) (rest (cddr x)))))
273 ((2)
274 (lambda (x)
275 (cons* a (f (car x) (cadr x) (caddr x))
276 (rest (cdddr x))))))))
277 ((a)
278 (lambda (x)
279 (list a)))
280 (()
281 (lambda (x)
282 '())))))))
283
284 (define (id? x)
285 (or (pair? x)
286 (hash-table? x)
287 (is-a? x <py-hashtable>)))
288
289 (define (format-- s l ha)
290 (set! l (if (id? l) l (list l)))
291 (aif it (hashq-ref ha s #f)
292 (string-join (it l) "")
293 (begin
294 (hashq-set! ha s (compile s))
295 (format-- s l ha))))
296
297 (define (format- str l)
298 (string-join ((compile str) (if (id? l) l (list l))) ""))
299
300 (define formatters (make-hash-table))
301
302 (define fnm 'formatter-map132)
303 (define-syntax format
304 (lambda (x)
305 (syntax-case x ()
306 ((_ a b)
307 (let ((s (syntax->datum #'a)))
308 (if (string? s)
309 (let* ((mod (datum->syntax #'a (module-name (current-module))))
310 (f (datum->syntax #'a fnm)))
311
312 (if (not (module-defined? (current-module) fnm))
313 (module-define! (current-module) fnm (make-hash-table)))
314
315 (with-syntax ((u (list #'@@ mod f)))
316 #'(format-- a b u)))
317 #'(format- a b))))
318 ((_ . _)
319 (error "wrong number of arguments to format"))
320 (_
321 #'format-))))
322
323 (define-method (py-mod (s <string>) l)
324 (format s l))