format2

1 files changed, 290 insertions, 0 deletions

diff --git a/modules/language/python/format2.scm b/modules/language/python/format2.scm
new file mode 100644
index 0000000..87f1fe7
--- /dev/null
+++ b/modules/language/python/format2.scm
@@ -0,0 +1,290 @@
+(define-module (language python format2)
+  #:use-module (ice-9 match)
+  #:use-module (parser stis-parser)
+  #:use-module (oop pf-objects)
+  #:use-module (oop goops)
+  #:use-module ((language python module re)     #:select (splitm splitmm))
+  #:use-module (language python exceptions)
+  #:use-module (language python number)
+  #:export (format perform-formatters init-formatters))
+
+(define scm-format (@ (guile) format))
+
+(define e-map  (f-seq "(" (mk-token (f* (f-not! (f-tag ")")))) ")"))
+(define e-conv (mk-token (f+ (f-reg! "[-#0 +]"))))
+(define e-min  (f-or! (mk-token (f+ (f-reg! "[0-9]")) string->number)
+		      (f-seq "*" (f-out #:*))))
+(define e-prec (f-seq "." (f-or!
+			   (mk-token (f+ (f-reg! "[0-9]")) string->number)
+			   (f-seq "*" (f-out #:*)))))
+(define e-len  (mk-token (f-reg! "[hlL]")))
+(define e-type (mk-token (f-reg! "[diouxXeEfFgGcrsa%]")))
+(define e      (f-list #:% "%" (ff? e-map) (ff? e-conv) (ff? e-min)
+		       (ff? e-prec) (ff? e-len) e-type))
+
+(define (map? l)
+  (let lp ((l l))
+    (match l
+     ((a (#:% #f . _) . l)
+      (lp l))
+     ((a (#:% _ . _) . l)
+      #t)
+     (_ #f))))
+
+(define (get-n p)
+  (match p
+    ((#:% #t _ `* `* . _)
+     2)
+    ((#:% #t _ `* _ . _)
+     1)
+    ((#:% #t _ _ `* . _)
+     1)
+    (_
+     0)))
+
+(define (create c min prec tp)
+  (define (get-intkind tp)
+    (match tp
+      ((or "d" "i"  "u")
+       "d")
+      ("o"
+       "o")
+      ((or "x" "X")
+       "x")))
+  
+  (let ((prec (if prec prec 6))
+	(c    (if c    c    "")))
+    (match tp
+      ("c"
+       (lambda (x)
+	 (if (and (number? x) (integer? x))
+	     (list->string (list (integer->char x)))
+	     x)))
+      ("s"  (lambda (x) (scm-format #f "~a" x)))
+      ("a"  (lambda (x) (scm-format #f "~a" x)))
+      ("r"  (lambda (x) (scm-format #f "~a" x)))
+      ("%"
+       (lambda (x) (* "%" (if min min 1))))
+      ((or "f" "F" "e" "E" "g" "G")
+       (let ((c (string->list c)))
+	 (define (make-decimal)
+	   (string-append
+	    "~"
+	    (if min (number->string min) "")
+	    ","
+	    (number->string prec)
+	    ",,,"
+	    (if (member #\0 c)
+		"0"
+		(if (member #\space c)
+		    " "
+		    ""))
+	    (if (member #\+ c) "@" "")
+	    "f"))
+	 (define (make-exp expchar)
+	   (string-append
+	    "~"
+	    (if min (number->string min) "")
+	    ","
+	    (number->string prec)
+	    ",,,,"
+	    (if (member #\0 c)
+		"0"
+		(if (member #\space c)
+		    " "
+		    ""))
+	    ",'"
+	    expchar
+	    (if (member #\+ c) "@" "")
+	    "e"))
+	 (match tp
+	    ((or "f" "F")
+	     (let ((pat (make-decimal)))
+	       (lambda (x) (scm-format #f pat x))))
+	    ((or "e" "E")
+	     (let ((pat (make-exp tp)))
+	       (lambda (x) (scm-format #f pat x))))
+	    ((or "g" "G")
+	     (let ((pat1 (make-decimal))
+		   (pat2 (make-exp (if (equal? tp "g") "e" "E"))))
+	       (lambda (x)
+		 (if (or (< (log10 x) -4) (if prec (< (log10 x) (- prec)) #f))
+		     (scm-format #f pat2 x)
+		     (scm-format #f pat1 x))))))))
+
+	 
+      ((or "d" "i" "u" "o" "x" "X")
+       (match c	      
+	 (""
+	  (let ((kind (get-intkind tp)))			     
+	    (if min
+		(let ((pat (string-append "~" (number->string min) ",' " kind)))
+		  (lambda (x)
+		    (scm-format #f pat x)))
+		(let ((pat (string-append "~" kind)))
+		  (lambda (x)
+		    (scm-format #f pat x))))))
+	 (_
+	  (if min
+	      (let ((c (string->list c)))
+		(if (and (member #\# c)
+			 (match tp
+				((or "x" "o" "X") #t)
+				(_ #f)))
+		    (set! c (cons #\0 c)))
+		(let* ((kind    (get-intkind tp))
+		       (padchar (if (member #\0 c) "0" " "))
+		       (pre     (if (member #\+ c)
+				    "~a"
+				    (if (member #\0 c)
+					"~a"
+					(if (member #\space c)
+					    "~a"
+					    ""))))		       
+		       (pos     (if (member #\+ c) "+"
+				    (if (member #\space c)
+					" "
+					padchar)))
+		       (kpre    (if (member #\# c)
+				    (match tp
+				     ("o" "0o")
+				     ((or "x" "X") "0x")
+				     (_ ""))
+				    ""))
+		       
+		       (neg     (if (or (member #\+ c)
+					(member #\space c)
+					(member #\0 c))
+				    "-"
+				    ""))
+		       (d       (string-append pre kpre "~"
+					       (number->string
+						(-  min
+						    (if (= (string-length kpre) 0) 0 2)
+						    (if (= (string-length pre ) 0) 0 1)))
+					       ",'"
+					       padchar
+					       kind)))
+		  (if (= (string-length pre) 0)
+		      (lambda (x)
+			(if (and (number? x) (integer? x))
+			    (scm-format #f d x)
+			    (raise (ValueError "not a integer, format spec %d"))))
+		      (lambda (x)
+			(if (and (number? x) (integer? x))
+			    (scm-format #f d (if (< x 0) neg pos) (abs x))
+			    (raise (ValueError "not a integer, format spec %d")))))))
+	      (let* ((kind (get-intkind tp))
+		     (pat  (string-append "~" kind)))
+		(lambda (x)
+		  (if (and (number? x) (integer? x))
+		      (scm-format #f pat x)
+		      (raise (ValueError "not a integer, format spec %d"))))))))))))
+      
+ 
+(define (analyze p)
+  (match p
+    ((#:% #f c `* `* _ tp)
+     (lambda (x min prec)
+       ((create c min prec tp) x)))
+    ((#:% #f c `* prec _ tp)
+     (lambda (x min)
+       ((create c min prec tp) x)))
+    ((#:% #f c min `* _ tp)
+     (lambda (x prec)
+       ((create c min prec tp) x)))
+    ((#:% #f c min prec _ tp)
+     (create c min prec tp))
+    ((#:% tag c min prec _ tp)
+     (let ((f (create c min prec tp)))
+       (lambda (x)       
+	 (f (pylist-ref x tag)))))))
+    
+
+(define (compile str)
+  (let* ((l (splitmm e str)))
+    (if (map? l)
+	(let lp ((l l))
+	  (match l
+	    ((a p . l)
+	     (let ((rest (lp l))
+		   (f    (analyze p)))	     
+	       (lambda (x)
+		 (cons* a (f x) (rest x)))))
+	    ((a)
+	     (lambda (x)
+	       (list a)))
+	    (()
+	     (lambda (x)
+	       '()))))
+	(let lp ((l l))
+	  (match l
+	    ((a p . l)
+	     (let ((rest (lp l))
+		   (n    (get-n   p))
+		   (f    (analyze p)))
+	       (case n
+		 ((0)
+		  (lambda (x)
+		    (cons* a (f (car x)) (rest (cdr x)))))
+		 ((1)
+		  (lambda (x)
+		    (cons* a (f (car x) (cadr x)) (rest (cddr x)))))
+		 ((2)
+		  (lambda (x)
+		    (cons* a (f (car x) (cadr x) (caddr x)) (rest (cdddr x))))))))	    
+	    ((a)
+	     (lambda (x)
+	       (list a)))
+	    (()
+	     (lambda (x)
+	       '())))))))
+
+(define (format-- c l) (string-join (c l) ""))
+(define (format- str l)
+  (format-- (compile str) l))
+
+(define formatters (make-hash-table))
+
+(define-syntax format
+  (lambda (x)
+    (syntax-case x ()
+      ((_ a b)
+       (let ((s (syntax->datum #'a)))
+	 (if (string? s)
+	     (let* ((mod (module-name (current-module)))
+		    (f   (gensym "str"))
+		    (l   (hash-ref formatters mod '())))	       
+	       (hash-set! formatters mod (cons (cons f s) l))
+	       (with-syntax ((u (datum->syntax #'a (list '@@ mod f)))
+			     (f (datum->syntax #'a f))
+			     (s s))				
+			    #'(catch #t
+				(lambda () (format-- u b))
+				(lambda x  (format-  a b)))))
+	     #'(format- a b))))
+      ((_ . _)
+       (error "wrong number of arguments to format"))
+      (_
+       #'format-))))
+
+(define-syntax perform-formatters
+  (lambda (x)
+    (syntax-case x ()
+      ((_)
+       (let ((mod (module-name (current-module))))
+	 (with-syntax ((mod (datum->syntax x mod)))
+	    #'(let lp ((l (hash-ref formatters 'mod '())))
+		(if (pair? l)
+		    (begin
+		      (define! (caar l) (compile (cdar l)))
+		      (lp (cdr l)))))))))))
+
+(define-syntax init-formatters
+  (lambda (x)
+    (hash-set! formatters (module-name (current-module)) '())
+    #f))
+	     
+	     
+(define-method (py-mod (s <string>) l)
+  (format s l))