Scheme Output/String Formatting Best Practices
Name:
Anonymous
2014-08-28 5:46
What is your preference? Are there other alternatives possible by composing R7RS base library procedures and macros?
; R7RS compliant version
(import (scheme write))
(define world "World)
(for-each display `("Hello, " ,world "!\n")
; R7RS with SRFI 28/29/48 for formatted string templates
(import (scheme write)
(srfi 28))
(define world "World)
(display (format "Hello, ~a!\n" world))
Name:
Anonymous
2014-09-02 0:20
EXPERT PRINT
(import (scheme base)
(scheme process-context)
(scheme write))
(define (terminal-port? port) #t)
(define *color-terminal-supported*
(let-syntax ((color-term? (syntax-rules () ((_ t names ...) (or (string=? t names) ...)))))
(let ((term (get-environment-variable "TERM")))
(if (string? term)
(color-term? term "xterm" "xterm-16color" "xterm-88color" "xterm-256color"
"rxvt" "rxvt-16color" "konsole" "konsole-16color")
#f))))
(define *color-text-enabled* #t)
(define (color-terminal-supported?)
*color-terminal-supported*)
(define (color-terminal-port? port)
(and *color-text-enabled*
*color-terminal-supported*
(terminal-port? port)))
(define (use-color-text?)
*color-text-enabled*)
(define (use-color-text value)
(set! *color-text-enabled* value))
(define-record-type <ansi-tty-code>
(make-ansi-tty-code code)
ansi-tty-code?
(code ansi-tty-code->string))
(define (print-ansi-tty-tokens port-or-ports tokens)
(let loop ((ports port-or-ports))
(unless (null? ports)
(let ((p (if (list? ports) (car ports) ports)))
(cond
((color-terminal-port? p)
(for-each
(lambda (t)
(if (ansi-tty-code? t)
(write-string (ansi-tty-code->string t) p)
(display t p)))
tokens)
(write-string "\x1B[0m" p))
(else
(for-each
(lambda (t)
(unless (ansi-tty-code? t)
(display t p)))
tokens))))
(when (list? port-or-ports)
(loop (cdr port-or-ports))))))
(define-syntax make-ansi-tty-command-token
(syntax-rules ()
((_ commands ...)
(begin (make-ansi-tty-code (string-append "\x1B[0" commands ... "m"))))))
(define-syntax define-print-syntax
(syntax-rules ()
((_ (name print-tokens) ((make-command-token) (command-name command-data) ...))
(begin
(define-syntax command-transformer
(syntax-rules (command-name ...)
((command-transformer ports (tokens (... ...)) ())
(print-tokens ports `(,tokens (... ...))))
((command-transformer ports (tokens (... ...)) (commands (... ...)) command-name expr (... ...))
(command-transformer ports (tokens (... ...)) (commands (... ...) command-data) expr (... ...))) ...
((command-transformer ports (tokens (... ...)) () x expr (... ...))
(command-transformer ports (tokens (... ...) x) () expr (... ...)))
((command-transformer ports (tokens (... ...)) (commands (... ...)) x expr (... ...))
(command-transformer ports (tokens (... ...) (make-command-token commands (... ...))) () x expr (... ...)))))
(define-syntax name
(syntax-rules ()
((name ports expressions (... ...))
(command-transformer ports () () expressions (... ...)))))))))
(define-print-syntax (print-ansi-tty print-ansi-tty-tokens)
((make-ansi-tty-command-token)
(:normal ";0")
(:bold ";1")
(:faint ";2")
(:italic ";3")
(:underline ";4")
(:blink ";5")
(:strikethrough ";9")
(:black ";30")
(:red ";31")
(:green ";32")
(:yellow ";33")
(:blue ";34")
(:magenta ";35")
(:cyan ";36")
(:white ";37")
(:black-bg ";40")
(:red-bg ";41")
(:green-bg ";42")
(:yellow-bg ";43")
(:blue-bg ";44")
(:magenta-bg ";45")
(:cyan-bg ";46")
(:white-bg ";47")))
(define (expert-print text)
(let ((port (current-output-port)))
(let loop ((i 0) (n (string-length text)))
(unless (>= i n)
(print-ansi-tty port :bold :underline :magenta " " :normal " ")
(loop (+ i 2) n)))
(newline port)
(let loop ((i 0) (n (string-length text)))
(unless (>= i n)
(if (= (modulo i 2) 0)
(print-ansi-tty port :bold :italic :magenta (string-ref text i))
(print-ansi-tty port :bold :italic :underline :cyan (string-ref text i)))
(loop (+ i 1) n)))
(newline port)))
(expert-print "EXPERT PROGRAMMER")
(newline)
NO EXCEPTIONS!
Newer Posts