format2
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>
Thu, 2 Aug 2018 10:06:12 +0000 (12:06 +0200)
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>
Thu, 2 Aug 2018 10:06:12 +0000 (12:06 +0200)
modules/language/python/format2.scm [new file with mode: 0644]

diff --git a/modules/language/python/format2.scm b/modules/language/python/format2.scm
new file mode 100644 (file)
index 0000000..87f1fe7
--- /dev/null
@@ -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))