Add format string compilation library (#28)
ober
1a7a5fb48dd3462e06ce856e53e852828cdeb881
new file mode 100644 --- /dev/null +++ b/lib/std/misc/fmt.sls @@ -0,0 +1,243 @@ +#!chezscheme +;;; (std misc fmt) — Format string compilation and formatting +;;; +;;; (define fmt-point (compile-format "Point(~a, ~a)")) +;;; (fmt-point 3 4) => "Point(3, 4)" +;;; +;;; (fmt "~a + ~a = ~a" 1 2 3) => "1 + 2 = 3" +;;; (fmt/port (current-output-port) "hello ~a~%" "world") + +(library (std misc fmt) + (export compile-format fmt fmt/port pad-left pad-right) + (import (chezscheme)) + + ;; --- String padding helpers --- + + (define (pad-left str width . maybe-char) + (let* ([ch (if (null? maybe-char) #\space (car maybe-char))] + [len (string-length str)] + [pad (- width len)]) + (if (<= pad 0) + str + (string-append (make-string pad ch) str)))) + + (define (pad-right str width . maybe-char) + (let* ([ch (if (null? maybe-char) #\space (car maybe-char))] + [len (string-length str)] + [pad (- width len)]) + (if (<= pad 0) + str + (string-append str (make-string pad ch))))) + + ;; --- Format string parser (compile-time version via meta define) --- + ;; Directives: + ;; (literal . "text"), (display), (write), (decimal), (binary), + ;; (octal), (hex), (newline), (tilde), (width . n) + + (meta define (ct-parse-fmt str) + (let ([len (string-length str)]) + (let loop ([i 0] [acc '()] [lit-start 0]) + (cond + [(>= i len) + (reverse + (if (< lit-start len) + (cons (cons 'literal (substring str lit-start len)) acc) + acc))] + [(char=? (string-ref str i) #\~) + (let ([acc (if (< lit-start i) + (cons (cons 'literal (substring str lit-start i)) acc) + acc)] + [j (+ i 1)]) + (when (>= j len) + (error 'parse-format-string "incomplete directive at end" str)) + (if (char-numeric? (string-ref str j)) + (let digit-loop ([k j] [digits '()]) + (cond + [(>= k len) + (error 'parse-format-string "incomplete width directive" str)] + [(char-numeric? (string-ref str k)) + (digit-loop (+ k 1) (cons (string-ref str k) digits))] + [(char=? (string-ref str k) #\w) + (let ([width (string->number (list->string (reverse digits)))]) + (loop (+ k 1) + (cons (cons 'width width) acc) + (+ k 1)))] + [else + (error 'parse-format-string + "expected 'w' after width digits" str)])) + (let ([ch (string-ref str j)]) + (case ch + [(#\a) (loop (+ j 1) (cons '(display) acc) (+ j 1))] + [(#\s) (loop (+ j 1) (cons '(write) acc) (+ j 1))] + [(#\d) (loop (+ j 1) (cons '(decimal) acc) (+ j 1))] + [(#\b) (loop (+ j 1) (cons '(binary) acc) (+ j 1))] + [(#\o) (loop (+ j 1) (cons '(octal) acc) (+ j 1))] + [(#\x) (loop (+ j 1) (cons '(hex) acc) (+ j 1))] + [(#\%) (loop (+ j 1) (cons '(newline) acc) (+ j 1))] + [(#\~) (loop (+ j 1) (cons '(tilde) acc) (+ j 1))] + [else + (error 'parse-format-string + "unknown directive" str ch)]))))] + [else + (loop (+ i 1) acc lit-start)])))) + + (meta define (ct-count-args directives) + (let loop ([ds directives] [n 0]) + (if (null? ds) + n + (case (caar ds) + [(literal newline tilde) (loop (cdr ds) n)] + [else (loop (cdr ds) (+ n 1))])))) + + (meta define (ct-directive->code d arg-ref) + (case (car d) + [(literal) `(display ,(cdr d) p)] + [(display) `(display ,arg-ref p)] + [(write) `(write ,arg-ref p)] + [(decimal) `(display (number->string ,arg-ref 10) p)] + [(binary) `(display (number->string ,arg-ref 2) p)] + [(octal) `(display (number->string ,arg-ref 8) p)] + [(hex) `(display (string-downcase (number->string ,arg-ref 16)) p)] + [(newline) '(newline p)] + [(tilde) `(display "~" p)] + [(width) `(display (pad-right (format "~a" ,arg-ref) ,(cdr d)) p)] + [else (error 'directive->code "unknown directive" d)])) + + ;; --- compile-format macro --- + ;; Parses the format string at compile time and produces a lambda + ;; that calls display/write/etc. directly — no runtime parsing. + + (define-syntax compile-format + (lambda (stx) + (syntax-case stx () + [(k fmt-str) + (string? (syntax->datum #'fmt-str)) + (let* ([str (syntax->datum #'fmt-str)] + [directives (ct-parse-fmt str)] + [nargs (ct-count-args directives)] + [arg-names (map (lambda (i) (string->symbol (format "a~a" i))) + (iota nargs))]) + ;; Build the entire lambda as a datum, then inject it + (let loop ([ds directives] [args arg-names] [body '()]) + (if (null? ds) + (let* ([body-forms (reverse body)] + [whole `(lambda ,arg-names + (let ([p (open-output-string)]) + ,@body-forms + (get-output-string p)))]) + (datum->syntax #'k whole)) + (let ([d (car ds)]) + (case (car d) + [(literal newline tilde) + (loop (cdr ds) args + (cons (ct-directive->code d #f) body))] + [else + (loop (cdr ds) (cdr args) + (cons (ct-directive->code d (car args)) body))])))))]))) + + ;; --- Runtime format string parser (same logic, runtime phase) --- + + (define (parse-format-string str) + (let ([len (string-length str)]) + (let loop ([i 0] [acc '()] [lit-start 0]) + (cond + [(>= i len) + (reverse + (if (< lit-start len) + (cons (cons 'literal (substring str lit-start len)) acc) + acc))] + [(char=? (string-ref str i) #\~) + (let ([acc (if (< lit-start i) + (cons (cons 'literal (substring str lit-start i)) acc) + acc)] + [j (+ i 1)]) + (when (>= j len) + (error 'parse-format-string "incomplete directive at end" str)) + (if (char-numeric? (string-ref str j)) + (let digit-loop ([k j] [digits '()]) + (cond + [(>= k len) + (error 'parse-format-string "incomplete width directive" str)] + [(char-numeric? (string-ref str k)) + (digit-loop (+ k 1) (cons (string-ref str k) digits))] + [(char=? (string-ref str k) #\w) + (let ([width (string->number (list->string (reverse digits)))]) + (loop (+ k 1) + (cons (cons 'width width) acc) + (+ k 1)))] + [else + (error 'parse-format-string + "expected 'w' after width digits" str)])) + (let ([ch (string-ref str j)]) + (case ch + [(#\a) (loop (+ j 1) (cons '(display) acc) (+ j 1))] + [(#\s) (loop (+ j 1) (cons '(write) acc) (+ j 1))] + [(#\d) (loop (+ j 1) (cons '(decimal) acc) (+ j 1))] + [(#\b) (loop (+ j 1) (cons '(binary) acc) (+ j 1))] + [(#\o) (loop (+ j 1) (cons '(octal) acc) (+ j 1))] + [(#\x) (loop (+ j 1) (cons '(hex) acc) (+ j 1))] + [(#\%) (loop (+ j 1) (cons '(newline) acc) (+ j 1))] + [(#\~) (loop (+ j 1) (cons '(tilde) acc) (+ j 1))] + [else + (error 'parse-format-string + "unknown directive" str ch)]))))] + [else + (loop (+ i 1) acc lit-start)])))) + + ;; --- Runtime formatting --- + + ;; Write formatted output to a port + (define (fmt/port port fmt-str . args) + (let ([directives (parse-format-string fmt-str)] + [remaining args]) + (for-each + (lambda (d) + (case (car d) + [(literal) (display (cdr d) port)] + [(display) + (when (null? remaining) + (error 'fmt/port "not enough arguments for ~a" fmt-str)) + (display (car remaining) port) + (set! remaining (cdr remaining))] + [(write) + (when (null? remaining) + (error 'fmt/port "not enough arguments for ~s" fmt-str)) + (write (car remaining) port) + (set! remaining (cdr remaining))] + [(decimal) + (when (null? remaining) + (error 'fmt/port "not enough arguments for ~d" fmt-str)) + (display (number->string (car remaining) 10) port) + (set! remaining (cdr remaining))] + [(binary) + (when (null? remaining) + (error 'fmt/port "not enough arguments for ~b" fmt-str)) + (display (number->string (car remaining) 2) port) + (set! remaining (cdr remaining))] + [(octal) + (when (null? remaining) + (error 'fmt/port "not enough arguments for ~o" fmt-str)) + (display (number->string (car remaining) 8) port) + (set! remaining (cdr remaining))] + [(hex) + (when (null? remaining) + (error 'fmt/port "not enough arguments for ~x" fmt-str)) + (display (string-downcase (number->string (car remaining) 16)) port) + (set! remaining (cdr remaining))] + [(newline) (newline port)] + [(tilde) (display "~" port)] + [(width) + (when (null? remaining) + (error 'fmt/port "not enough arguments for ~w" fmt-str)) + (display (pad-right (format "~a" (car remaining)) (cdr d)) port) + (set! remaining (cdr remaining))] + [else (error 'fmt/port "unknown directive" d)])) + directives))) + + ;; Return formatted string + (define (fmt fmt-str . args) + (let ([p (open-output-string)]) + (apply fmt/port p fmt-str args) + (get-output-string p))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-fmt.ss @@ -0,0 +1,114 @@ +#!chezscheme +;;; Tests for (std misc fmt) — format string compilation + +(import (chezscheme) (std misc fmt)) + +(define pass 0) +(define fail 0) + +(define-syntax test + (syntax-rules () + [(_ name expr expected) + (guard (exn + [#t (set! fail (+ fail 1)) + (printf "FAIL ~a: exception ~a~%" name + (if (message-condition? exn) (condition-message exn) exn))]) + (let ([got expr]) + (if (equal? got expected) + (begin (set! pass (+ pass 1)) + (printf " ok ~a~%" name)) + (begin (set! fail (+ fail 1)) + (printf "FAIL ~a: got ~s, expected ~s~%" name got expected)))))])) + +(printf "--- (std misc fmt) tests ---~%") + +;; --- pad-left / pad-right --- +(test "pad-left basic" (pad-left "hi" 5) " hi") +(test "pad-left no pad needed" (pad-left "hello" 3) "hello") +(test "pad-left exact" (pad-left "abc" 3) "abc") +(test "pad-left custom char" (pad-left "42" 5 #\0) "00042") +(test "pad-right basic" (pad-right "hi" 5) "hi ") +(test "pad-right no pad needed" (pad-right "hello" 3) "hello") +(test "pad-right custom char" (pad-right "x" 4 #\.) "x...") + +;; --- fmt: basic ~a directive --- +(test "fmt ~a string" (fmt "hello ~a" "world") "hello world") +(test "fmt ~a number" (fmt "n=~a" 42) "n=42") +(test "fmt ~a symbol" (fmt "sym: ~a" 'foo) "sym: foo") +(test "fmt multiple ~a" (fmt "~a + ~a = ~a" 1 2 3) "1 + 2 = 3") + +;; --- fmt: ~s (write) directive --- +(test "fmt ~s string" (fmt "got ~s" "hello") "got \"hello\"") +(test "fmt ~s char" (fmt "char: ~s" #\a) "char: #\\a") + +;; --- fmt: numeric directives --- +(test "fmt ~d decimal" (fmt "dec: ~d" 255) "dec: 255") +(test "fmt ~b binary" (fmt "bin: ~b" 10) "bin: 1010") +(test "fmt ~o octal" (fmt "oct: ~o" 255) "oct: 377") +(test "fmt ~x hex" (fmt "hex: ~x" 255) "hex: ff") +(test "fmt ~x hex zero" (fmt "~x" 0) "0") + +;; --- fmt: ~% newline --- +(test "fmt ~% newline" (fmt "line1~%line2") "line1\nline2") +(test "fmt multiple ~%" (fmt "a~%~%b") "a\n\nb") + +;; --- fmt: ~~ tilde escape --- +(test "fmt ~~ tilde" (fmt "100~~") "100~") +(test "fmt ~~ in middle" (fmt "a~~b") "a~b") + +;; --- fmt: ~w fixed width --- +(test "fmt ~w pad short" (fmt "~10w|" "hi") "hi |") +(test "fmt ~w no pad long" (fmt "~3w|" "hello") "hello|") + +;; --- fmt: empty and edge cases --- +(test "fmt empty string" (fmt "") "") +(test "fmt no directives" (fmt "hello") "hello") +(test "fmt only literal" (fmt "just text") "just text") + +;; --- compile-format --- +(define fmt-point (compile-format "Point(~a, ~a)")) +(test "compile-format basic" (fmt-point 3 4) "Point(3, 4)") + +(define fmt-hex (compile-format "0x~x")) +(test "compile-format hex" (fmt-hex 255) "0xff") + +(define fmt-greeting (compile-format "Hello, ~a! You are ~d years old.")) +(test "compile-format multi" (fmt-greeting "Alice" 30) "Hello, Alice! You are 30 years old.") + +(define fmt-empty (compile-format "")) +(test "compile-format empty" (fmt-empty) "") + +(define fmt-no-args (compile-format "constant")) +(test "compile-format no args" (fmt-no-args) "constant") + +(define fmt-escapes (compile-format "100~~ done~%")) +(test "compile-format escapes" (fmt-escapes) "100~ done\n") + +(define fmt-write (compile-format "val=~s")) +(test "compile-format write" (fmt-write "hi") "val=\"hi\"") + +(define fmt-binary (compile-format "~b in binary")) +(test "compile-format binary" (fmt-binary 42) "101010 in binary") + +(define fmt-octal (compile-format "~o in octal")) +(test "compile-format octal" (fmt-octal 255) "377 in octal") + +(define fmt-width (compile-format "|~8w|")) +(test "compile-format width" (fmt-width "hi") "|hi |") + +;; --- fmt/port --- +(test "fmt/port basic" + (let ([p (open-output-string)]) + (fmt/port p "~a=~d" "x" 42) + (get-output-string p)) + "x=42") + +(test "fmt/port newline" + (let ([p (open-output-string)]) + (fmt/port p "a~%b") + (get-output-string p)) + "a\nb") + +;; --- Summary --- +(printf "~%~a passed, ~a failed~%" pass fail) +(when (> fail 0) (exit 1))