customizing write-char (was Re: Format strings are wrong)

[Alex Shinn <foof@xxxxxxxxxxxxx>]

Taylor's idea of passing a custom write-char is not so useful by
itself, but if you turn it into a FOLD operation then you can get more
interesting results.  Below is an implementation of fundamental
write/display enumerators and some examples of customizing them.

Although interesting, I don't think this could taken seriously due to
being extremely slow.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; general string utilities

(define (display->string x)
  (with-output-to-string (lambda () (display x))))

(define (write->string x)
  (with-output-to-string (lambda () (write x))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; kind of a fold for folders, or a partial application compose

;; (procN kons ... (proc2 kons (proc1 kons knil)))
(define (cat>> kons knil procs)
  (let loop ((ls procs) (acc knil))
    (if (null? ls) acc (loop (cdr ls) ((car ls) kons acc)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; basic formatters

(define (display>> obj)
  (lambda (kons knil)
    (cond
      ((string? obj)
       (string-fold kons knil obj))
      ((pair? obj)
       (kons
        #\)
        (let loop ((acc (kons #\( knil))
                   (ls obj))
          (let ((acc2 ((display>> (car ls)) kons acc))
                (rest (cdr ls)))
            (cond
              ((null? rest) acc2)
              ((pair? rest) (loop (kons #\space acc2) rest))
              (else
               ((display>> rest) kons ((display>> kons) acc2 " . "))))))))
      ((vector? obj)
       ((display>> (vector->list obj)) kons (kons #\# knil)))
      (else ;; add more cases to avoid this
       ((display>> (display->string obj)) kons knil)))))

(define (write>> obj)
  (lambda (kons knil)
    (cond
      ((string? obj)
       (kons #\" (string-fold kons (kons #\" knil) obj)))
      ((pair? obj)
       (kons
        #\)
        (let loop ((acc (kons #\( knil))
                   (ls obj))
          (let ((acc2 ((write>> (car ls)) kons acc))
                (rest (cdr ls)))
            (cond
              ((null? rest) acc2)
              ((pair? rest) (loop (kons #\space acc2) rest))
              (else
               ((write>> rest) kons ((write>> " . ") kons acc2))))))))
      ((vector? obj)
       ((write>> (vector->list obj)) kons (kons #\# knil)))
      (else ;; note, intentionally display>>
       ((display>> (write->string obj)) kons knil)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; example 1: formatting with a column counter

(define (column-writer c i)
  (write-char c)
  (if (eqv? c #\newline) 0 (+ i 1)))

(define (fmt>> . procs)
  (cat>> column-writer 0 procs))

;; a "constant" procedure
(define (fresh-line kons knil)
  (if (zero? knil)
    knil
    (kons #\newline knil)))

(define (tab>> col . opt)
  (lambda (kons knil)
    (let* ((modulo? (and (pair? opt) (car opt)))
           (width (if modulo? (modulo col knil)
                      (- col knil))))
      (if (positive? width)
        ((display>> (make-string width #\space)) kons knil)
        knil))))

; (fmt>> (display>> "value: ") (write>> '(a "b" 3)) fresh-line)

; (fmt>> (display>> "Name: ") (write>> "Socrates") (tab>> 20)
;        (display>> "Sex: ") (write>> "male") fresh-line
;        (display>> "Location: ") (write>> "Athens") (tab>> 20)
;        (display>> "Job: ") (write>> "corrupting the youth") fresh-line)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; example 2: case folding

(define (upcase>> . procs)
  (lambda (kons knil)
    (cat>> (lambda (c i) (kons (char-upcase c) i)) knil procs)))

(define (downcase>> . procs)
  (lambda (kons knil)
    (cat>> (lambda (c i) (kons (char-downcase c) i)) knil procs)))

;; titlecase requires storing previous char's script type in the
;; accumulator

; (fmt>> (upcase>> (display>> "hElLo ")) (downcase>> (display>> "WOrlD!")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; example 3: default radix

;; This example changes the meaning of the accumulator from
;; current-column to current-radix.  Similarly you could specify default
;; precision for floating point numbers.  A full-featured set of
;; formatting procedures would probably define a record to hold various
;; state information and pass that as the accumulator.

;; current radix is stored in knil
(define (number>> n . opt)
  (lambda (kons knil)
    (let ((radix (if (pair? opt) (car opt) knil)))
      ((display>> (number->string n radix)) kons knil))))

;; just overrides current radix
(define (radix>> radix . procs)
  (lambda (kons knil)
    (cat>> kons radix procs)))

;; start off with default radix 10
(define (fmt-radix>> . procs)
  (cat>> (lambda (c i) (write-char c) i) 10 procs))

; (fmt-radix>> (display>> "decimal: ") (number>> 123)
;              (radix>> 16
;                       (display>> " hex: ") (number>> 123)
;                       (display>> " octal: ") (number>> 123 8)))

-- 
Alex