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