unofficial mirror of guile-devel@gnu.org 
 help / color / mirror / Atom feed
* Fmt Module
@ 2011-03-12 21:14 Noah Lavine
  2011-03-13 21:37 ` Andreas Rottmann
  0 siblings, 1 reply; 13+ messages in thread
From: Noah Lavine @ 2011-03-12 21:14 UTC (permalink / raw)
  To: guile-devel

[-- Attachment #1: Type: text/plain, Size: 1100 bytes --]

Hello all,

I just completed packaging Alex Shinn's fmt library for Guile, and I'd
like us to include it in the trunk. The library's home page (with
documentation!) is http://synthcode.com/scheme/fmt/.

It looks like a nice formatting library, and I imagine it would be
useful to people who want to generate html for the web module.
However, the real reason I want it in is because it has the ability to
format C source code nicely, and all of the plans for the JIT complier
involve automatically generating a lot of C. (I'm only attaching the
basic library right now, but I hope to package up the C formatting
stuff soon.)

The files are all attached. To use the library, put all of the files
in a folder, open Guile in that folder, do (load "fmt-guile.scm"), and
then (use-modules (fmt fmt)). If you want to test the library, do
(load "test-fmt.scm"). It passes all tests on my machine.

fmt-guile.scm is a new file, but the other ones are almost identical
to the upstream version. I'm going to try to get the changes merged so
it will be easy for us to maintain.

What do you think?

Thanks,
Noah

[-- Attachment #2: fmt-column.scm --]
[-- Type: application/octet-stream, Size: 12999 bytes --]

;;;; fmt-block.scm -- columnar formatting
;;
;; Copyright (c) 2006-2007 Alex Shinn.  All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Columnar formatting
;;
;; A line-oriented formatter.  Takes a list of
;;   (line-fmt1 gen-fmt1 line-fmt2 gen-fmt2 ...)
;; and formats each of the gen-fmt1 formats as columns, printed
;; side-by-side, each line allowing post-processing done by line-fmt1
;; (just use dsp if you want to display the lines verbatim).

;; Continuations come to the rescue to make this work properly,
;; letting us weave the output between different columns without
;; needing to build up intermediate strings.

(define (fmt-columns . ls)
  (lambda (orig-st)
    (call-with-current-continuation
      (lambda (return)
        (define (infinite? x)
          (and (pair? x) (pair? (cdr x)) (pair? (cddr x)) (caddr x)))
        (let ((q1 '())
              (q2 '())
              (remaining (length (remove infinite? ls))))
          (define (enq! proc) (set! q2 (cons proc q2)))
          (define (deq!) (let ((proc (car q1))) (set! q1 (cdr q1)) proc))
          (define (line-init!) (set! q1 (reverse q2)) (set! q2 '()))
          (define (line-done?) (null? q1))
          (define (next cont)
            (enq! cont)
            (if (line-done?) 
                (cond
                  ((not (positive? remaining))
                   (return orig-st))
                  (else                 ; newline
                   (set! orig-st (nl orig-st))
                   (line-init!)
                   ((deq!) #f)))
                ((deq!) #f)))
          (define (make-empty-col fmt)
            (define (blank *ignored*)
              (set! orig-st ((fmt "") orig-st)) ; empty output
              (next blank))    ; infinite loop, next terminates for us
            blank)
          (define (make-col st fmt gen)
            (let ((acc '()))            ; buffer incomplete lines
              (lambda (*ignored*)
                (define (output* str st)
                  (let lp ((i 0))
                    (let ((nli (string-index str #\newline i)))
                      (cond
                        (nli
                         (let ((line
                                (string-concatenate-reverse
                                 (cons (substring/shared str i nli) acc))))
                           (set! acc '())
                           (set! orig-st ((fmt line) orig-st))
                           (call-with-current-continuation next) 
                           (lp (+ nli 1))))
                        (else
                         (set! acc (cons (substring/shared str i) acc))))))
                  ;; update - don't output or the string port will fill up
                  (fmt-update str st))
                ;; gen threads through it's own state, ignore result
                (gen (fmt-set-writer! (copy-fmt-state st) output*))
                ;; reduce # of remaining columns
                (set! remaining (- remaining 1))
                ;; (maybe) loop with an empty column in place
                (if (not (positive? remaining))
                    (return orig-st)
                    (next (make-empty-col fmt))))))
          ;; queue up the initial formatters
          (for-each
           (lambda (col)
             (let ((st (fmt-set-port! (copy-fmt-state orig-st)
                                      (open-output-string))))
               (enq! (make-col st (car col) (cat (cadr col) fl)))))
           ls)
          (line-init!)
          ;; start
          ((deq!) #f))))))

(define (columnar . ls)
  (define (proportional-width? w) (and (number? w) (< 0 w 1)))
  (define (build-column ls)
    (let-optionals* ls ((fixed-width #f)
                        (width #f)
                        (last? #t)
                        (tail '())
                        (gen #f)
                        (prefix '())
                        (align 'left)
                        (infinite? #f))
      (define (scale-width st)
        (max 1 (inexact->exact
                (truncate (* width (- (fmt-width st) fixed-width))))))
      (define (affix x)
        (cond
          ((pair? tail)
           (lambda (str)
             (cat (string-concatenate prefix)
                  (x str)
                  (string-concatenate tail))))
          ((pair? prefix)
           (lambda (str) (cat (string-concatenate prefix) (x str))))
          (else x)))
      (list
       ;; line formatter
       (affix
        (if (and last? (not (pair? tail)) (eq? align 'left))
            dsp
            (if (proportional-width? width)
                (case align
                  ((right)
                   (lambda (str) (lambda (st) ((pad (scale-width st) str) st))))
                  ((center)
                   (lambda (str) (lambda (st) ((pad/both (scale-width st) str) st))))
                  (else
                   (lambda (str) (lambda (st) ((pad/right (scale-width st) str) st)))))
                (case align
                  ((right) (lambda (str) (pad width str)))
                  ((center) (lambda (str) (pad/both width str)))
                  (else (lambda (str) (pad/right width str)))))))
       ;; generator
       (if (< 0 width 1)
           (lambda (st) ((with-width (scale-width st) gen) st))
           (with-width width gen))
       infinite?
       )))
  (define (adjust-widths ls border-width)
    (let* ((fixed-ls
            (filter (lambda (x) (and (number? (car x)) (>= (car x) 1))) ls))
           (fixed-total (fold + border-width (map car fixed-ls)))
           (scaled-ls (filter (lambda (x) (proportional-width? (car x))) ls))
           (rest
            (/ (- 1 (fold + 0 (map car scaled-ls)))
               (- (length ls) (+ (length fixed-ls) (length scaled-ls)) ))))
      (if (negative? rest)
          (error "fractional widths must sum to less than 1"
                 (map car scaled-ls)))
      (map
       (lambda (col)
         (cons fixed-total
               (if (not (number? (car col))) (cons rest (cdr col)) col)))
       ls)))
  (define (finish ls border-width)
    (apply fmt-columns
           (map build-column (adjust-widths (reverse ls) border-width))))
  (let lp ((ls ls) (strs '()) (align 'left) (infinite? #f)
           (width #t) (border-width 0) (res '()))
    (cond
      ((null? ls)
       (if (pair? strs)
           (finish (cons (cons (caar res)
                               (cons #t (cons (append (reverse strs)
                                                      (caddar res))
                                              (cdddar res))))
                         (cdr res))
                   border-width)
           (finish (cons (cons (caar res) (cons #t (cddar res))) (cdr res))
                   border-width)))
      ((string? (car ls))
       (if (string-index (car ls) #\newline)
           (error "column string literals can't contain newlines")
           (lp (cdr ls) (cons (car ls) strs) align infinite?
               width (+ border-width (string-length (car ls))) res)))
      ((number? (car ls))
       (lp (cdr ls) strs align infinite? (car ls) border-width res))
      ((eq? (car ls) 'infinite)
       (lp (cdr ls) strs align #t width border-width res))
      ((symbol? (car ls))
       (lp (cdr ls) strs (car ls) infinite? width border-width res))
      ((procedure? (car ls))
       (lp (cdr ls) '() 'left #f #t border-width
           (cons (list width #f '() (car ls) (reverse strs) align infinite?)
                 res)))
      (else
       (error "invalid column" (car ls))))))

;; break lines only, don't fmt-join short lines or justify
(define (fold-lines . ls)
  (lambda (st)
    (define output (fmt-writer st))
    (define (kons-in-line str st)
      (let ((len (string-length str))
            (space (- (fmt-width st) (fmt-col st))))
        (cond
          ((or (<= len space) (not (positive? space)))
           (output str st))
          (else
           (kons-in-line
            (substring/shared str space len)
            (output nl-str
                    (output (substring/shared str 0 space) st)))))))
    ((fmt-let
      'writer
      (lambda (str st)
        (let lp ((str str) (st st))
          (let ((nli (string-index str #\newline)))
            (cond
              ((not nli)
               (kons-in-line str st))
              (else
               (lp (substring/shared str (+ nli 1))
                   (output nl-str
                           (kons-in-line
                            (substring/shared str 0 nli)
                            st))))))))
      (apply-cat ls))
     st)))

(define (wrap-fold-words seq knil max-width get-width line . o)
  (let* ((last-line (if (pair? o) (car o) line))
         (vec (if (pair? seq) (list->vector seq) seq))
         (len (vector-length vec))
         (len-1 (- len 1))
         (breaks (make-vector len #f))
         (penalties (make-vector len #f))
         (widths
          (list->vector
           (map get-width (if (pair? seq) seq (vector->list seq))))))
    (define (largest-fit i)
      (let lp ((j (+ i 1)) (width (vector-ref widths i)))
        (let ((width (+ width 1 (vector-ref widths j))))
          (cond
            ((>= width max-width) (- j 1))
            ((>= j len-1) len-1)
            (else (lp (+ j 1) width))))))
    (define (min-penalty! i)
      (cond
        ((>= i len-1) 0)
        ((vector-ref penalties i))
        (else
         (vector-set! penalties i (expt (+ max-width 1) 3))
         (let ((k (largest-fit i)))
           (let lp ((j i) (width 0))
             (if (<= j k)
                 (let* ((width (+ width (vector-ref widths j)))
                        (break-penalty
                         (+ (max 0 (expt (- max-width (+ width (- j i))) 3))
                            (min-penalty! (+ j 1)))))
                   (cond
                     ((< break-penalty (vector-ref penalties i))
                      (vector-set! breaks i j)
                      (vector-set! penalties i break-penalty)))
                   (lp (+ j 1) width)))))
         (if (>= (vector-ref breaks i) len-1)
             (vector-set! penalties i 0))
         (vector-ref penalties i))))
    (define (sub-list i j)
      (let lp ((i i) (res '()))
        (if (> i j)
            (reverse res)
            (lp (+ i 1) (cons (vector-ref vec i) res)))))
    ;; compute optimum breaks
    (vector-set! breaks len-1 len-1)
    (vector-set! penalties len-1 0)
    (min-penalty! 0)
    ;; fold
    (let lp ((i 0) (acc knil))
      (let ((break (vector-ref breaks i)))
        (if (>= break len-1)
            (last-line (sub-list i len-1) acc)
            (lp (+ break 1) (line (sub-list i break) acc)))))))

;; XXXX don't split, traverse the string manually and keep track of
;; sentence endings so we can insert two spaces
(define (wrap-fold str . o)
  (apply wrap-fold-words (string-tokenize str) o))

(define (wrap-lines . ls)
  (define (print-line ls st)
    (nl ((fmt-join dsp ls " ") st)))
  (define buffer '())
  (lambda (st)
    ((fmt-let
      'writer
      (lambda (str st) (set! buffer (cons str buffer)) st)
      (apply-cat ls))
     st)
    (wrap-fold (string-concatenate-reverse buffer)
               st (fmt-width st) string-length print-line)))

(define (justify . ls)
  (lambda (st)
    (let ((width (fmt-width st))
          (output (fmt-writer st))
          (buffer '()))
      (define (justify-line ls st)
        (if (null? ls)
            (nl st)
            (let* ((sum (fold (lambda (s n) (+ n (string-length s))) 0 ls))
                   (len (length ls))
                   (diff (max 0 (- width sum)))
                   (sep (make-string (quotient diff (- len 1)) #\space))
                   (rem (remainder diff (- len 1))))
              (output
               (call-with-output-string
                 (lambda (p)
                   (display (car ls) p)
                   (let lp ((ls (cdr ls)) (i 1))
                     (cond
                       ((pair? ls)
                        (display sep p)
                        (if (<= i rem) (write-char #\space p))
                        (display (car ls) p)
                        (lp (cdr ls) (+ i 1)))))
                   (newline p)))
               st))))
      (define (justify-last ls st)
        (nl ((fmt-join dsp ls " ") st)))
      ((fmt-let
        'writer
        (lambda (str st) (set! buffer (cons str buffer)) st)
        (apply-cat ls))
       st)
      (wrap-fold (string-concatenate-reverse buffer)
                 st width string-length justify-line justify-last))))

(define (fmt-file path)
  (lambda (st)
    (call-with-input-file path
      (lambda (p)
        (let lp ((st st))
          (let ((line (read-line p)))
            (if (eof-object? line)
                st
                (lp (nl ((dsp line) st))))))))))

(define (line-numbers . o)
  (let ((start (if (pair? o) (car o) 1)))
    (fmt-join/range dsp start #f nl-str)))


[-- Attachment #3: fmt-guile.scm --]
[-- Type: application/octet-stream, Size: 1698 bytes --]

(define-module (fmt fmt)
  #:use-module (ice-9 rdelim) ; for read-line
  #:use-module (ice-9 optargs) ; for let-optional*
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-6)
  #:use-module (srfi srfi-13)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-69)
  #:export (
            new-fmt-state
            fmt fmt-start fmt-if fmt-capture fmt-let fmt-bind fmt-null
            fmt-ref fmt-set! fmt-add-properties! fmt-set-property!
            fmt-col fmt-set-col! fmt-row fmt-set-row!
            fmt-radix fmt-set-radix! fmt-precision fmt-set-precision!
            fmt-properties fmt-set-properties! fmt-width fmt-set-width!
            fmt-writer fmt-set-writer! fmt-port fmt-set-port!
            fmt-decimal-sep fmt-set-decimal-sep!
            copy-fmt-state
            fmt-file fmt-try-fit cat apply-cat nl fl nl-str
            fmt-join fmt-join/last fmt-join/dot
            fmt-join/prefix fmt-join/suffix fmt-join/range
            pad pad/right pad/left pad/both trim trim/left trim/both trim/length
            fit fit/left fit/both tab-to space-to wrt wrt/unshared dsp
            pretty pretty/unshared slashified maybe-slashified
            num num/si num/fit num/comma radix fix ellipses
            upcase downcase titlecase pad-char comma-char decimal-char
            with-width wrap-lines fold-lines justify
            make-string-fmt-transformer
            make-space make-nl-space display-to-string write-to-string
            fmt-columns columnar line-numbers
           )

  )

(eval-when (compile load eval)
  (load "let-optionals.scm"))
(load "make-eq-table.scm")
(load "mantissa.scm")
(load "fmt.scm")
(load "fmt-pretty.scm")
(load "fmt-column.scm")

[-- Attachment #4: fmt-pretty.scm --]
[-- Type: application/octet-stream, Size: 9018 bytes --]

;;;; fmt-pretty.scm -- pretty printing format combinator
;;
;; Copyright (c) 2006-2007 Alex Shinn.  All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; additional settings

(define (fmt-shares st) (fmt-ref st 'shares))
(define (fmt-set-shares! st x) (fmt-set! st 'shares x))
(define (fmt-copy-shares st)
  (fmt-set-shares! (copy-fmt-state st) (copy-shares (fmt-shares st))))

(define (copy-shares shares)
  (let ((tab (make-eq?-table)))
    (hash-table-walk
     (car shares)
     (lambda (obj x) (eq?-table-set! tab obj (cons (car x) (cdr x)))))
    (cons tab (cdr shares))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; utilities

(define (fmt-shared-write obj proc)
  (lambda (st)
    (let* ((shares (fmt-shares st))
           (cell (and shares (eq?-table-ref (car shares) obj))))
      (if (pair? cell)
          (cond
            ((cdr cell)
             ((fmt-writer st) (gen-shared-ref (car cell) "#") st))
            (else
             (set-car! cell (cdr shares))
             (set-cdr! cell #t)
             (set-cdr! shares (+ (cdr shares) 1))
             (proc ((fmt-writer st) (gen-shared-ref (car cell) "=") st))))
          (proc st)))))

(define (fmt-join/shares fmt ls . o)
  (let ((sep (dsp (if (pair? o) (car o) " "))))
    (lambda (st)
      (if (null? ls)
          st
          (let* ((shares (fmt-shares st))
                 (tab (car shares))
                 (output (fmt-writer st)))
            (let lp ((ls ls) (st st))
              (let ((st ((fmt (car ls)) st))
                    (rest (cdr ls)))
                (cond
                 ((null? rest) st)
                 ((pair? rest)
                  (call-with-shared-ref/cdr rest st shares
                      (lambda (st) (lp rest st))
                    sep))
                 (else ((fmt rest) (output ". " (sep st))))))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; pretty printing

(define (non-app? x)
  (if (pair? x)
      (or (not (or (null? (cdr x)) (pair? (cdr x))))
          (non-app? (car x)))
      (not (symbol? x))))

(define syntax-abbrevs
  '((quote . "'") (quasiquote . "`") (unquote . ",") (unquote-splicing . ",@")
    ))

(define (pp-let ls)
  (if (and (pair? (cdr ls)) (symbol? (cadr ls)))
      (pp-with-indent 2 ls)
      (pp-with-indent 1 ls)))

(define indent-rules
  `((lambda . 1) (define . 1)
    (let . ,pp-let) (loop . ,pp-let)
    (let* . 1) (letrec . 1) (letrec* . 1) (and-let* . 1) (let1 . 2)
    (let-values . 1) (let*-values . 1) (receive . 2) (parameterize . 1)
    (let-syntax . 1) (letrec-syntax . 1) (syntax-rules . 1) (syntax-case . 2)
    (match . 1) (match-let . 1) (match-let* . 1)
    (if . 3) (when . 1) (unless . 1) (case . 1) (while . 1) (until . 1)
    (do . 2) (dotimes . 1) (dolist . 1) (test . 1)
    (condition-case . 1) (guard . 1) (rec . 1)
    (call-with-current-continuation . 0)
    ))

(define indent-prefix-rules
  `(("with-" . -1) ("call-with-" . -1) ("define-" . 1))
  )

(define indent-suffix-rules
  `(("-case" . 1))
  )

(define (pp-indentation form)
  (let ((indent
         (cond
          ((assq (car form) indent-rules) => cdr)
          ((and (symbol? (car form))
                (let ((str (symbol->string (car form))))
                  (or (find (lambda (rx) (string-prefix? (car rx) str))
                            indent-prefix-rules)
                      (find (lambda (rx) (string-suffix? (car rx) str))
                            indent-suffix-rules))))
           => cdr)
          (else #f))))
    (if (and (number? indent) (negative? indent))
        (max 0 (- (+ (length+ form) indent) 1))
        indent)))

(define (pp-with-indent indent-rule ls)
  (lambda (st)
    (let* ((col1 (fmt-col st))
           (st ((cat "(" (pp-object (car ls))) st))
           (col2 (fmt-col st))
           (fixed (take* (cdr ls) (or indent-rule 1)))
           (tail (drop* (cdr ls) (or indent-rule 1)))
           (st2 (fmt-copy-shares st))
           (first-line
            ((fmt-to-string (cat " " (fmt-join/shares pp-flat fixed " "))) st2))
           (default
             (let ((sep (make-nl-space (+ col1 1))))
               (cat sep (fmt-join/shares pp-object (cdr ls) sep) ")"))))
      (cond
       ((< (+ col2 (string-length first-line)) (fmt-width st2))
        ;; fixed values on first line
        (let ((sep (make-nl-space
                    (if indent-rule (+ col1 2) (+ col2 1)))))
          ((cat first-line
                (cond
                 ((not (or (null? tail) (pair? tail)))
                  (cat ". " (pp-object tail)))
                 ((> (length+ (cdr ls)) (or indent-rule 1))
                  (cat sep (fmt-join/shares pp-object tail sep)))
                 (else
                  fmt-null))
                ")")
           st2)))
       (indent-rule ;;(and indent-rule (not (pair? (car ls))))
        ;; fixed values lined up, body indented two spaces
        ((fmt-try-fit
          (lambda (st)
            ((cat
              " "
              (fmt-join/shares pp-object fixed (make-nl-space (+ col2 1)))
              (if (pair? tail)
                  (let ((sep (make-nl-space (+ col1 2))))
                    (cat sep (fmt-join/shares pp-object tail sep)))
                  "")
              ")")
             (fmt-copy-shares st)))
          default)
         st))
       (else
        ;; all on separate lines
        (default st))))))

(define (pp-app ls)
  (let ((indent-rule (pp-indentation ls)))
    (if (procedure? indent-rule)
        (indent-rule ls)
        (pp-with-indent indent-rule ls))))

;; the elements may be shared, just checking the top level list
;; structure
(define (proper-non-shared-list? ls shares)
  (let ((tab (car shares)))
    (let lp ((ls ls))
      (or (null? ls)
          (and (pair? ls)
               (not (eq?-table-ref tab ls))
               (lp (cdr ls)))))))

(define (pp-flat x)
  (cond
    ((pair? x)
     (fmt-shared-write
      x
      (cond
        ((and (pair? (cdr x)) (null? (cddr x))
              (assq (car x) syntax-abbrevs))
         => (lambda (abbrev)
              (cat (cdr abbrev) (pp-flat (cadr x)))))
        (else
         (cat "(" (fmt-join/shares pp-flat x " ") ")")))))
    ((vector? x)
     (fmt-shared-write
      x
      (cat "#(" (fmt-join/shares pp-flat (vector->list x) " ") ")")))
    (else
     (lambda (st) ((write-with-shares x (fmt-shares st)) st)))))

(define (pp-pair ls)
  (fmt-shared-write
   ls
   (cond
    ;; one element list, no lines to break
    ((null? (cdr ls))
     (cat "(" (pp-object (car ls)) ")"))
    ;; quote or other abbrev
    ((and (pair? (cdr ls)) (null? (cddr ls))
          (assq (car ls) syntax-abbrevs))
     => (lambda (abbrev)
          (cat (cdr abbrev) (pp-object (cadr ls)))))
    (else
     (fmt-try-fit
      (lambda (st) ((pp-flat ls) (fmt-copy-shares st)))
      (lambda (st)
        (if (and (non-app? ls)
                 (proper-non-shared-list? ls (fmt-shares st)))
            ((pp-data-list ls) st)
            ((pp-app ls) st))))))))

(define (pp-data-list ls)
  (lambda (st)
    (let* ((output (fmt-writer st))
           (st (output "(" st))
           (col (fmt-col st))
           (width (- (fmt-width st) col))
           (st2 (fmt-copy-shares st)))
      (cond
        ((and (pair? (cdr ls)) (pair? (cddr ls)) (pair? (cdddr ls))
              ((fits-in-columns ls pp-flat width) st2))
         => (lambda (ls)
              ;; at least four elements which can be broken into columns
              (let* ((prefix (make-nl-space (+ col 1)))
                     (widest (+ 1 (car ls)))
                     (columns (quotient width widest))) ; always >= 2
                (let lp ((ls (cdr ls)) (st st2) (i 1))
                  (cond
                    ((null? ls)
                     (output ")" st))
                    ((null? (cdr ls))
                     (output ")" (output (car ls) st)))
                    (else
                     (let ((st (output (car ls) st)))
                       (if (>= i columns)
                           (lp (cdr ls) (output prefix st) 1)
                           (let* ((pad (- widest (string-length (car ls))))
                                  (st (output (make-space pad) st)))
                             (lp (cdr ls) st (+ i 1)))))))))))
        (else
         ;; no room, print one per line
         ((cat (fmt-join pp-object ls (make-nl-space col)) ")") st))))))

(define (pp-vector vec)
  (fmt-shared-write vec (cat "#" (pp-data-list (vector->list vec)))))

(define (pp-object obj)
  (cond
    ((pair? obj) (pp-pair obj))
    ((vector? obj) (pp-vector obj))
    (else (lambda (st) ((write-with-shares obj (fmt-shares st)) st)))))

(define (pretty obj)
  (fmt-bind 'shares (cons (make-shared-ref-table obj) 0)
            (cat (pp-object obj) fl)))

(define (pretty/unshared obj)
  (fmt-bind 'shares (cons (make-eq?-table) 0) (cat (pp-object obj) fl)))


[-- Attachment #5: fmt.scm --]
[-- Type: application/octet-stream, Size: 39793 bytes --]

;;;; fmt.scm -- extensible formatting library
;;
;; Copyright (c) 2006-2008 Alex Shinn.  All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt

;; Modified slightly from fmt 0.6

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; string utilities

(define (write-to-string x)
  (call-with-output-string (lambda (p) (write x p))))

(define (display-to-string x)
  (if (string? x)
      x
      (call-with-output-string (lambda (p) (display x p)))))

(define nl-str
  (call-with-output-string newline))

(define (make-space n) (make-string n #\space))
(define (make-nl-space n) (string-append nl-str (make-string n #\space)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; list utilities

(define (take* ls n)   ; handles dotted lists and n > length
  (cond ((zero? n) '())
        ((pair? ls) (cons (car ls) (take* (cdr ls) (- n 1))))
        (else '())))

(define (drop* ls n)   ; may return the dot
  (cond ((zero? n) ls)
        ((pair? ls) (drop* (cdr ls) (- n 1)))
        (else ls)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; format state representation

;; Use a flexible representation optimized for common cases -
;; frequently accessed values are in fixed vector slots, with a
;; `properties' slot holding an alist for all other values.

(define *default-fmt-state*
  (vector 0 0 10 '() #\space #f 78 #f #f #f #f #f))

(define fmt-state? vector?)

(define (new-fmt-state . o)
  (let ((st (if (pair? o) (car o) (current-output-port))))
    (if (vector? st)
        st
        (fmt-set-writer!
         (fmt-set-port! (copy-fmt-state *default-fmt-state*) st)
         fmt-write))))

(define (copy-fmt-state st)
  (let* ((len (vector-length st))
         (res (make-vector len)))
    (do ((i 0 (+ i 1)))
        ((= i len))
      (vector-set! res i (vector-ref st i)))
    (fmt-set-properties! res (map (lambda (x) (cons (car x) (cdr x)))
                                  (fmt-properties res)))
    res))

(define (fmt-row st) (vector-ref st 0))
(define (fmt-col st) (vector-ref st 1))
(define (fmt-radix st) (vector-ref st 2))
(define (fmt-properties st) (vector-ref st 3))
(define (fmt-pad-char st) (vector-ref st 4))
(define (fmt-precision st) (vector-ref st 5))
(define (fmt-width st) (vector-ref st 6))
(define (fmt-writer st) (vector-ref st 7))
(define (fmt-port st) (vector-ref st 8))
(define (fmt-decimal-sep st) (vector-ref st 9))
(define (fmt-string-width st) (vector-ref st 10))
(define (fmt-ellipses st) (vector-ref st 11))

(define (fmt-set-row! st x) (vector-set! st 0 x) st)
(define (fmt-set-col! st x) (vector-set! st 1 x) st)
(define (fmt-set-radix! st x) (vector-set! st 2 x) st)
(define (fmt-set-properties! st x) (vector-set! st 3 x) st)
(define (fmt-set-pad-char! st x) (vector-set! st 4 x) st)
(define (fmt-set-precision! st x) (vector-set! st 5 x) st)
(define (fmt-set-width! st x) (vector-set! st 6 x) st)
(define (fmt-set-writer! st x) (vector-set! st 7 x) st)
(define (fmt-set-port! st x) (vector-set! st 8 x) st)
(define (fmt-set-decimal-sep! st x) (vector-set! st 9 x) st)
(define (fmt-set-string-width! st x) (vector-set! st 10 x) st)
(define (fmt-set-ellipses! st x) (vector-set! st 11 x) st)

(define (fmt-ref st key . o)
  (case key
    ((row) (fmt-row st))
    ((col) (fmt-col st))
    ((radix) (fmt-radix st))
    ((properties) (fmt-properties st))
    ((writer) (fmt-writer st))
    ((port) (fmt-port st))
    ((precision) (fmt-precision st))
    ((pad-char) (fmt-pad-char st))
    ((width) (fmt-width st))
    ((decimal-sep) (fmt-decimal-sep st))
    ((string-width) (fmt-string-width st))
    ((ellipses) (fmt-ellipses st))
    (else (cond ((assq key (fmt-properties st)) => cdr)
                ((pair? o) (car o))
                (else #f)))))

(define (fmt-set-property! st key val)
  (cond ((assq key (fmt-properties st))
         => (lambda (cell) (set-cdr! cell val) st))
        (else (fmt-set-properties!
               st
               (cons (cons key val) (fmt-properties st))))))

(define (fmt-set! st key val)
  (case key
    ((row) (fmt-set-row! st val))
    ((col) (fmt-set-col! st val))
    ((radix) (fmt-set-radix! st val))
    ((properties) (fmt-set-properties! st val))
    ((pad-char) (fmt-set-pad-char! st val))
    ((precision) (fmt-set-precision! st val))
    ((writer) (fmt-set-writer! st val))
    ((port) (fmt-set-port! st val))
    ((width) (fmt-set-width! st val))
    ((decimal-sep) (fmt-set-decimal-sep! st val))
    ((string-width) (fmt-set-string-width! st val))
    ((ellipses) (fmt-set-ellipses! st val))
    (else (fmt-set-property! st key val))))

(define (fmt-add-properties! st alist)
  (for-each (lambda (x) (fmt-set! st (car x) (cdr x))) alist)
  st)

(define (fmt-let key val . ls)
  (lambda (st)
    (let ((orig-val (fmt-ref st key)))
      (fmt-set! ((apply-cat ls) (fmt-set! st key val)) key orig-val))))

(define (fmt-bind key val . ls)
  (lambda (st) ((apply-cat ls) (fmt-set! st key val))))

(define (fix prec . ls) (fmt-let 'precision prec (apply-cat ls)))
(define (radix rad . ls) (fmt-let 'radix rad (apply-cat ls)))
(define (pad-char ch . ls) (fmt-let 'pad-char ch (apply-cat ls)))
(define (comma-char ch . ls) (fmt-let 'comma-char ch (apply-cat ls)))
(define (decimal-char ch . ls) (fmt-let 'decimal-sep ch (apply-cat ls)))
(define (with-width w . ls) (fmt-let 'width w (apply-cat ls)))
(define (ellipses ell . ls) (fmt-let 'ellipses ell (apply-cat ls)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; the basic interface

(define (fmt-start st initializer proc)
  (cond
    ((or (output-port? st) (fmt-state? st))
     (proc (initializer st))
     (if #f #f))
    ((eq? #t st)
     (proc (initializer (current-output-port)))
     (if #f #f))
    ((eq? #f st)
     (get-output-string
      (fmt-port (proc (initializer (open-output-string))))))
    (else (error "unknown format output" st))))

(define (fmt st . args)
  (fmt-start st new-fmt-state (apply-cat args)))

(define (fmt-update str st)
  (let ((len (string-length str))
        (nli (string-index-right str #\newline))
        (str-width (fmt-string-width st)))
    (if nli
        (let ((row (+ (fmt-row st) 1 (string-count str #\newline 0 nli))))
          (fmt-set-row!
           (fmt-set-col! st (if str-width
                                (str-width str (+ nli 1) len)
                                (- len (+ nli 1))))
           row))
        (fmt-set-col! st (+ (fmt-col st)
                            (if str-width
                                (str-width str 0 len)
                                len))))))

(define (fmt-write str st)
  (display str (fmt-port st))
  (fmt-update str st))

(define (apply-cat procs)
  (lambda (st)
    (let loop ((ls procs) (st st))
      (if (null? ls)
          st
          (loop (cdr ls) ((dsp (car ls)) st))))))

(define (cat . ls) (apply-cat ls))

(define (fmt-null st) st)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; control structures

(define (fmt-if check pass . o)
  (let ((fail (if (pair? o) (car o) (lambda (x) x))))
    (lambda (st) (if (check st) ((dsp pass) st) ((dsp fail) st)))))

(define (fmt-try-fit proc . fail)
  (if (null? fail)
      proc
      (lambda (orig-st)
        (let ((width (fmt-width orig-st))
              (buffer '()))
          (call-with-current-continuation
            (lambda (return)
              (define (output* str st)
                (let lp ((i 0) (col (fmt-col st)))
                  (let ((nli (string-index str #\newline i)))
                    (if nli
                        (if (> (+ (- nli i) col) width)
                            (return ((apply fmt-try-fit fail) orig-st))
                            (lp (+ nli 1) 0))
                        (let* ((len (string-length str))
                               (col (+ (- len i) col)))
                          (if (> col width)
                              (return ((apply fmt-try-fit fail) orig-st))
                              (begin
                                (set! buffer (cons str buffer))
                                (fmt-update str st))))))))
              (proc (fmt-set-port! (fmt-set-writer! (copy-fmt-state orig-st)
                                                    output*)
                                   (open-output-string)))
              ((fmt-writer orig-st)
               (string-concatenate-reverse buffer)
               orig-st)))))))

(define (fits-in-width gen width)
  (lambda (st)
    (let ((output (fmt-writer st))
          (port (open-output-string)))
      (call-with-current-continuation
        (lambda (return)
          (define (output* str st)
            (let ((st (fmt-update str st)))
              (if (> (fmt-col st) width)
                  (return #f)
                  (begin
                    (display str port)
                    st))))
          (gen (fmt-set-port! (fmt-set-writer! (copy-fmt-state st) output*)
                              port))
          (get-output-string port))))))

(define (fits-in-columns ls write width)
  (lambda (st)
    (let ((max-w (quotient width 2)))
      (let lp ((ls ls) (res '()) (widest 0))
        (cond
          ((pair? ls)
           (let ((str ((fits-in-width (write (car ls)) max-w) st)))
             (and str
                  (lp (cdr ls)
                      (cons str res)
                      (max (string-length str) widest)))))
          ((null? ls) (cons widest (reverse res)))
          (else #f))))))

(define (fmt-capture producer consumer)
  (lambda (st)
    (let ((port (open-output-string)))
      (producer (fmt-set-writer! (fmt-set-port! (copy-fmt-state st) port)
                                 fmt-write))
      ((consumer (get-output-string port)) st))))

(define (fmt-to-string producer)
  (fmt-capture producer (lambda (str) (lambda (st) str))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; standard formatters

(define (nl st)
  ((fmt-writer st) nl-str st))

;; output a newline iff we're not at the start of a fresh line
(define (fl st)
  (if (zero? (fmt-col st)) st (nl st)))

;; tab to a given tab-stop
(define (tab-to . o)
  (lambda (st)
    (let* ((tab-width (if (pair? o) (car o) 8))
           (rem (modulo (fmt-col st) tab-width)))
      (if (positive? rem)
          ((fmt-writer st)
           (make-string (- tab-width rem) (fmt-pad-char st))
           st)
          st))))

;; move to an explicit column
(define (space-to col)
  (lambda (st)
    (let ((width (- col (fmt-col st))))
      (if (positive? width)
          ((fmt-writer st) (make-string width (fmt-pad-char st)) st)
          st))))

(define (fmt-join fmt ls . o)
  (let ((sep (dsp (if (pair? o) (car o) ""))))
    (lambda (st)
      (if (null? ls)
          st
          (let lp ((ls (cdr ls))
                   (st ((fmt (car ls)) st)))
            (if (null? ls)
                st
                (lp (cdr ls) ((fmt (car ls)) (sep st)))))))))

(define (fmt-join/prefix fmt ls . o)
  (if (null? ls)
      fmt-null
      (let ((sep (dsp (if (pair? o) (car o) ""))))
        (cat sep (fmt-join fmt ls sep)))))
(define (fmt-join/suffix fmt ls . o)
  (if (null? ls)
      fmt-null
      (let ((sep (dsp (if (pair? o) (car o) ""))))
        (cat (fmt-join fmt ls sep) sep))))

(define (fmt-join/last fmt fmt/last ls . o)
  (let ((sep (dsp (if (pair? o) (car o) ""))))
    (lambda (st)
      (cond
        ((null? ls)
         st)
        ((null? (cdr ls))
         ((fmt/last (car ls)) (sep st)))
        (else
         (let lp ((ls (cdr ls))
                  (st ((fmt (car ls)) st)))
           (if (null? (cdr ls))
               ((fmt/last (car ls)) (sep st))
               (lp (cdr ls) ((fmt (car ls)) (sep st))))))))))

(define (fmt-join/dot fmt fmt/dot ls . o)
  (let ((sep (dsp (if (pair? o) (car o) ""))))
    (lambda (st)
      (cond
        ((pair? ls)
         (let lp ((ls (cdr ls))
                  (st ((fmt (car ls)) st)))
           (cond
             ((null? ls) st)
             ((pair? ls) (lp (cdr ls) ((fmt (car ls)) (sep st))))
             (else ((fmt/dot ls) (sep st))))))
        ((null? ls) st)
        (else ((fmt/dot ls) st))))))

(define (fmt-join/range fmt start . o)
  (let-optionals* o ((end #f) (sep ""))
    (lambda (st)
      (let lp ((i (+ start 1)) (st ((fmt start) st)))
        (if (and end (>= i end))
            st
            (lp (+ i 1) ((fmt i) ((dsp sep) st))))))))

(define (pad/both width . ls)
  (fmt-capture
   (apply-cat ls)
   (lambda (str)
     (lambda (st)
       (let ((diff (- width ((or (fmt-string-width st) string-length) str)))
             (output (fmt-writer st)))
         (if (positive? diff)
             (let* ((diff/2 (quotient diff 2))
                    (left (make-string diff/2 (fmt-pad-char st)))
                    (right (if (even? diff)
                               left
                               (make-string (+ 1 diff/2) (fmt-pad-char st)))))
               (output right (output str (output left st))))
             (output str st)))))))

(define (pad width . ls)
  (lambda (st)
    (let* ((col (fmt-col st))
           (padder
            (lambda (st)
              (let ((diff (- width (- (fmt-col st) col))))
                (if (positive? diff)
                    ((fmt-writer st) (make-string diff (fmt-pad-char st)) st)
                    st)))))
      ((cat (apply-cat ls) padder) st))))

(define pad/right pad)

(define (pad/left width . ls)
  (fmt-capture
   (apply-cat ls)
   (lambda (str)
     (lambda (st)
       (let* ((str-width ((or (fmt-string-width st) string-length) str))
              (diff (- width str-width)))
         ((fmt-writer st)
          str
          (if (positive? diff)
              ((fmt-writer st) (make-string diff (fmt-pad-char st)) st)
              st)))))))

(define (trim/buffered width fmt proc)
  (fmt-capture
   fmt
   (lambda (str)
     (lambda (st)
       (let* ((str-width ((or (fmt-string-width st) string-length) str))
              (diff (- str-width width)))
         ((fmt-writer st)
          (if (positive? diff)
              (proc str str-width diff st)
              str)
          st))))))

(define (trim width . ls)
  (lambda (st)
    (let ((ell (fmt-ellipses st)))
      (if ell
          ((trim/buffered
            width
            (apply-cat ls)
            (lambda (str str-width diff st)
              (let* ((ell (if (char? ell) (string ell) ell))
                     (ell-len (string-length ell))
                     (diff (- (+ str-width ell-len) width)))
                (if (negative? diff)
                    ell
                    (string-append
                     (substring/shared str 0 (- (string-length str) diff))
                     ell)))))
           st)
          (let ((output (fmt-writer st))
                (start-col (fmt-col st)))
            (call-with-current-continuation
              (lambda (return)
                (define (output* str st)
                  (let* ((len ((or (fmt-string-width st) string-length) str))
                         (diff (- (+ (- (fmt-col st) start-col) len) width)))
                    (if (positive? diff)
                        (return
                         (fmt-set-writer!
                          (output (substring/shared str 0 (- len diff)) st)
                          output))
                        (output str st))))
                ((fmt-let 'writer output* (apply-cat ls)) st))))))))

(define (trim/length width . ls)
  (lambda (st)
    (call-with-current-continuation
      (lambda (return)
        (let ((output (fmt-writer st))
              (sum 0))
          (define (output* str st)
            (let ((len (string-length str)))
              (set! sum (+ sum len))
              (if (> sum width)
                  (return
                   (fmt-set-writer!
                    (output (substring/shared str 0 (- len (- sum width))) st)
                    output))
                  (output str st))))
          ((fmt-let 'writer output* (apply-cat ls)) st))))))

(define (trim/left width . ls)
  (trim/buffered
   width
   (apply-cat ls)
   (lambda (str str-width diff st)
     (let ((ell (fmt-ellipses st)))
       (if ell
           (let* ((ell (if (char? ell) (string ell) ell))
                  (ell-len (string-length ell))
                  (diff (- (+ str-width ell-len) width)))
             (if (negative? diff)
                 ell
                 (string-append ell (substring/shared str diff))))
           (substring/shared str diff))))))

(define (trim/both width . ls)
  (trim/buffered
   width
   (apply-cat ls)
   (lambda (str str-width diff st)
     (let ((ell (fmt-ellipses st)))
       (if ell
           (let* ((ell (if (char? ell) (string ell) ell))
                  (ell-len (string-length ell))
                  (diff (- (+ str-width ell-len ell-len) width))
                  (left (quotient diff 2))
                  (right (- (string-length str) (quotient (+ diff 1) 2))))
             (if (negative? diff)
                 ell
                 (string-append ell (substring/shared str left right) ell)))
           (substring/shared str
                             (quotient (+ diff 1) 2)
                             (- (string-length str) (quotient diff 2))))))))

(define (fit width . ls)
  (pad width (trim width (apply-cat ls))))
(define (fit/left width . ls)
  (pad/left width (trim/left width (apply-cat ls))))
(define (fit/both width . ls)
  (pad/both width (trim/both width (apply-cat ls))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; String-map formatters

(define (make-string-fmt-transformer proc)
  (lambda ls
    (lambda (st)
      (let ((base-writer (fmt-writer st)))
        ((fmt-let
          'writer (lambda (str st) (base-writer (proc str) st))
          (apply-cat ls))
         st)))))

(define upcase (make-string-fmt-transformer string-upcase))
(define downcase (make-string-fmt-transformer string-downcase))
(define titlecase (make-string-fmt-transformer string-titlecase))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Numeric formatting

(define *min-e* -1024)
(define *bot-f* (expt 2 52))
;;(define *top-f* (* 2 *bot-f*))

(define (integer-log a base)
  (if (zero? a)
      0
      (inexact->exact (ceiling (/ (log (+ a 1)) (log base))))))
(define (integer-length* a)
  (if (negative? a)
      (integer-log (- 1 a) 2)
      (integer-log a 2)))

(define invlog2of
  (let ((table (make-vector 37))
        (log2 (log 2)))
    (do ((b 2 (+ b 1)))
        ((= b 37))
      (vector-set! table b (/ log2 (log b))))
    (lambda (b)
      (if (<= 2 b 36)
          (vector-ref table b)
          (/ log2 (log b))))))

(define fast-expt
  (let ((table (make-vector 326)))
    (do ((k 0 (+ k 1)) (v 1 (* v 10)))
        ((= k 326))
      (vector-set! table k v))
    (lambda (b k)
      (if (and (= b 10) (<= 0 k 326))
          (vector-ref table (inexact->exact (truncate k)))
          (expt b k)))))

(define (mirror-of c)
  (case c ((#\() #\)) ((#\[) #\]) ((#\{) #\}) ((#\<) #\>) (else c)))

;; General algorithm based on "Printing Floating-Point Numbers Quickly
;; and Accurately" by Burger and Dybvig (FP-Printing-PLDI96.pdf).  The
;; code below will be hard to read out of that context until it's
;; cleaned up.

(define (num->string n st . opt)
  (call-with-output-string
    (lambda (port)
      (let-optionals* opt
          ((base (fmt-radix st))
           (digits (fmt-precision st))
           (sign? #f)
           (commify? #f)
           (comma-sep (and commify? (fmt-ref st 'comma-char #\,)))
           (decimal-sep (or (fmt-decimal-sep st)
                            (if (eqv? comma-sep #\.) #\, #\.)))
           (comma-rule (if (eq? commify? #t) 3 commify?)))

        (define (write-positive n)

          (let* ((m+e (mantissa+exponent (exact->inexact n)))
                 (f (car m+e))
                 (e (cadr m+e))
                 (inv-base (invlog2of base))
                 (round? (even? f))
                 (smaller (if round? <= <))
                 (bigger (if round? >= >)))

            (define (write-digit d)
              (let ((d (inexact->exact (truncate d))))
                (write-char
                 (cond ((< d 10)
                        (integer->char (+ d (char->integer #\0))))
                       ((< d 36)
                        (integer->char (+ (- d 10) (char->integer #\A))))
                       (else (error "invalid digit: " d)))
                 port)))

            (define (pad d i) ;; just pad 0's, not #'s
              (write-digit d)
              (let lp ((i (- i 1)))
                (cond
                 ((>= i 0)
                  (if (and commify?
                           (if digits
                               (and (> i digits)
                                    (zero? (modulo (- i (- digits 1))
                                                   comma-rule)))
                               (and (positive? i)
                                    (zero? (modulo i comma-rule)))))
                      (display comma-sep port))
                  (if (= i (- digits 1))
                      (display decimal-sep port))
                  (write-char #\0 port)
                  (lp (- i 1))))))

            (define (pad-all d i)
              (write-digit d)
              (let lp ((i (- i 1)))
                (cond
                 ((> i 0)
                  (if (and commify? (zero? (modulo i comma-rule)))
                      (display comma-sep port))
                  (write-char #\0 port)
                  (lp (- i 1)))
                 ((and (= i 0) (inexact? n))
                  (display decimal-sep port)
                  (write-digit 0)))))

            (define (pad-sci d i k)
              (write-digit d)
              (write-char #\e port)
              (cond
               ((positive? k)
                (write-char #\+ port)
                (write (- k 1) port))
               (else
                (write k port))))

            (define (scale r s m+ m- k f e)
              (let ((est (inexact->exact
                          (ceiling (- (* (+ e (integer-length* f) -1)
                                         (invlog2of base))
                                      1.0e-10)))))
                (if (not (negative? est))
                    (fixup r (* s (fast-expt base est)) m+ m- est)
                    (let ((skale (fast-expt base (- est))))
                      (fixup (* r skale) s
                             (* m+ skale) (* m- skale) est)))))

            (define (fixup r s m+ m- k)
              (if (bigger (+ r m+) s)
                  (lead r s m+ m- (+ k 1))
                  (lead (* r base) s (* m+ base) (* m- base) k)))

            (define (lead r s m+ m- k)
              (cond
               ;;((and (not digits) (> k 14))
               ;; (generate-sci r s m+ m- k))
               ;;((and (not digits) (< k -4))
               ;; (if (>= (/ r s) base)
               ;;     (generate-sci (/ r base) s (/ m+ base) (/ m- base) k)
               ;;     (generate-sci r s m+ m- k)))
               ((and (not digits) (or (> k 14) (< k -4)))
                (write n port))      ; XXXX using native write for now
               (else
                (cond
                 ((and (not digits)
                       (not (positive? k)))
                  (write-char #\0 port)
                  (display decimal-sep port)
                  (let lp ((i 0))
                    (cond
                     ((> i k)
                      (write-char #\0 port)
                      (lp (- i 1)))))))
                (if digits
                    (generate-fixed r s m+ m- k)
                    (generate-all r s m+ m- k)))))

            (define (generate-all r s m+ m- k)
              (let gen ((r r) (m+ m+) (m- m-) (i k))
                (cond ((= i k))
                      ((zero? i)
                       (display decimal-sep port))
                      ((and commify?
                            (positive? i)
                            (zero? (modulo i comma-rule)))
                       (display comma-sep port)))
                (let ((d (quotient r s))
                      (r (remainder r s)))
                  (if (not (smaller r m-))
                      (cond
                       ((not (bigger (+ r m+) s))
                        (write-digit d)
                        (gen (* r base) (* m+ base) (* m- base) (- i 1)))
                       (else
                        (pad-all (+ d 1) i)))
                      (if (not (bigger (+ r m+) s))
                          (pad-all d i)
                          (pad-all (if (< (* r 2) s) d (+ d 1)) i))))))

            ;; This is ugly because we need to keep a list of all
            ;; output of the form x9999... in case we get to the end
            ;; of the precision and need to round up.
            (define (generate-fixed r s m+ m- k)
              (let ((i0 (- (+ k digits) 1))
                    (stack (if (<= k 0)
                               (append (make-list (min (- k) digits) 0)
                                       (list decimal-sep 0))
                               '())))
                (define (write-digit-list ls)
                  (for-each
                   (lambda (x) (if (number? x) (write-digit x) (display x port)))
                   ls))
                (define (flush)
                  (write-digit-list (reverse stack))
                  (set! stack '()))
                (define (flush/rounded)
                  (let lp ((ls stack) (res '()))
                    (cond
                     ((null? ls)
                      (write-digit-list (cons #\1 res)))
                     ((not (number? (car ls)))
                      (lp (cdr ls) (cons (car ls) res)))
                     ((= (car ls) (- base 1))
                      (lp (cdr ls) (cons #\0 res)))
                     (else
                      (write-digit-list
                       (append (reverse (cdr ls))
                               (cons (+ 1 (car ls)) res))))))
                  (set! stack '()))
                (define (output digit)
                  (if (and (number? digit) (< digit (- base 1)))
                      (flush))
                  (set! stack (cons digit stack)))
                (let gen ((r r) (m+ m+) (m- m-) (i i0))
                  (cond ((= i i0))
                        ((= i (- digits 1))
                         (output decimal-sep))
                        ((and commify?
                              (> i digits)
                              (zero? (modulo (- i (- digits 1))
                                             comma-rule)))
                         (output comma-sep)))
                  (let ((d (quotient r s))
                        (r (remainder r s)))
                    (cond
                     ((< i 0)
                      (let ((d2 (* 2 (if (>= (* r 2) s) (+ d 1) d))))
                        (if (and (not (> (- k) digits))
                                 (or (> d2 base)
                                     (and (= d2 base)
                                          (pair? stack)
                                          (number? (car stack))
                                          (odd? (car stack)))))
                            (flush/rounded)
                            (flush))))
                     ((smaller r m-)
                      (cond
                       ((= d base)
                        (flush/rounded)
                        (pad 0 i))
                       (else
                        (flush)
                        (if (bigger (+ r m+) s)
                            (pad (if (< (* r 2) s) d (+ d 1)) i)
                            (pad d i)))))
                     ((bigger (+ r m+) s)
                      (flush)
                      (pad (+ d 1) i))
                     (else
                      (output d)
                      (gen (* r base) (* m+ base)
                           (* m- base) (- i 1))))))))

            (define (generate-sci r s m+ m- k)
              (let gen ((r r) (m+ m+) (m- m-) (i k))
                (cond ((= i (- k 1)) (display decimal-sep port)))
                (let ((d (quotient r s))
                      (r (remainder r s)))
                  (if (not (smaller r m-))
                      (cond
                       ((not (bigger (+ r m+) s))
                        (write-digit d)
                        (gen (* r base) (* m+ base) (* m- base) (- i 1)))
                       (else (pad-sci (+ d 1) i k)))
                      (if (not (bigger (+ r m+) s))
                          (pad-sci d i k)
                          (pad-sci (if (< (* r 2) s) d (+ d 1)) i k))))))

            (cond
             ((negative? e)
              (if (or (= e *min-e*) (not (= f *bot-f*)))
                  (scale (* f 2) (* (expt 2 (- e)) 2) 1 1 0 f e)
                  (scale (* f 2 2) (* (expt 2 (- 1 e)) 2) 2 1 0 f e)))
             (else
              (if (= f *bot-f*)
                  (let ((be (expt 2 e)))
                    (scale (* f be 2) 2 be be 0 f e))
                  (let* ((be (expt 2 e)) (be1 (* be 2)))
                    (scale (* f be1 2) (* 2 2) be1 be 0 f e)))))))

        (define (write-real n sign?)
          (cond
           ((negative? n)
            (if (char? sign?)
                (begin (display sign? port) (write-positive (abs n))
                       (display (mirror-of sign?) port))
                (begin (write-char #\- port) (write-positive (abs n)))))
           (else
            (if (and sign? (not (char? sign?)))
                (write-char #\+ port))
            (write-positive n))))

        (let ((imag (imag-part n)))
          (cond
           ((and base (not (and (integer? base) (<= 2 base 36))))
            (error "invalid base for numeric formatting" base))
           ((zero? imag)
            (cond
             ((and (not digits) (exact? n) (not (integer? n)))
              (write-real (numerator n) sign?)
              (write-char #\/ port)
              (write-real (denominator n) #f))
             (else
              (write-real n sign?))))
           (else (write-real (real-part n) sign?)
                 (write-real imag #t)
                 (write-char #\i port))))))))

(define (num n . opt)
  (lambda (st) ((fmt-writer st) (apply num->string n st opt) st)))

(define (num/comma n . o)
  (lambda (st)
    (let-optionals* o
        ((base (fmt-radix st))
         (digits (fmt-precision st))
         (sign? #f)
         (comma-rule 3)
         (comma-sep (fmt-ref st 'comma-char #\,))
         (decimal-sep (or (fmt-decimal-sep st)
                          (if (eqv? comma-sep #\.) #\, #\.))))
      ((num n base digits sign? comma-rule comma-sep decimal-sep) st))))

;; SI suffix formatting, as used in --human-readable options to some
;; GNU commands (such as ls).  See
;;
;;   http://www.bipm.org/en/si/si_brochure/chapter3/prefixes.html
;;   http://physics.nist.gov/cuu/Units/binary.html
;;
;; Note: lowercase "k" for base 10, uppercase "K" for base 2

(define num/si
  (let* ((names10 '#("" "k" "M" "G" "T" "E" "P" "Z" "Y"))
         (names2 (list->vector
                  (cons ""
                        (cons "Ki" (map (lambda (s) (string-append s "i"))
                                        (cddr (vector->list names10))))))))
    (lambda (n . o)
      (let-optionals* o ((base 1024)
                         (suffix "")
                         (names (if (= base 1024) names2 names10)))
        (let* ((k (min (inexact->exact (floor (/ (log n) (log base))))
                       (vector-length names)))
               (n2 (/ (round (* (/ n (expt base k)) 10)) 10)))
          (cat (if (integer? n2)
                   (number->string (inexact->exact n2))
                   (exact->inexact n2))
               (vector-ref names k)
               (if (zero? k) "" suffix)))))))

;; Force a number into a fixed width, print as #'s if doesn't fit.
;; Needs to be wrapped in a PAD if you want to expand to the width.

(define (num/fit width n . args)
  (fmt-capture
   (apply num n args)
   (lambda (str)
     (lambda (st)
       (if (> (string-length str) width)
           (let ((prec (if (and (pair? args) (pair? (cdr args)))
                           (cadr args)
                           (fmt-precision st))))
             (if prec
                 (let* ((decimal-sep
                         (or (fmt-ref st 'decimal-sep)
                             (if (eqv? #\. (fmt-ref st 'comma-sep)) #\, #\.)))
                        (diff (- width (+ prec
                                          (if (char? decimal-sep)
                                              1
                                              (string-length decimal-sep))))))
                   ((cat (if (positive? diff) (make-string diff #\#) "")
                         decimal-sep (make-string prec #\#))
                    st))
                 ((fmt-writer st) (make-string width #\#) st)))
           ((fmt-writer st) str st))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; shared structure utilities

(define (eq?-table-ref tab x) (hash-table-ref/default tab x #f))
(define (eq?-table-set! tab x v) (hash-table-set! tab x v))

;; XXXX extend for records and other container data types
(define (make-shared-ref-table obj)
  (let ((tab (make-eq?-table))
        (res (make-eq?-table))
        (index 0))
    (let walk ((obj obj))
      (cond
        ((eq?-table-ref tab obj)
         => (lambda (i) (eq?-table-set! tab obj (+ i 1))))
        ((not (or (symbol? obj) (number? obj) (char? obj)
                  (boolean? obj) (null? obj) (eof-object? obj)))
         (eq?-table-set! tab obj 1)
         (cond
           ((pair? obj)
            (walk (car obj))
            (walk (cdr obj)))
           ((vector? obj)
            (let ((len (vector-length obj)))
              (do ((i 0 (+ i 1))) ((>= i len))
                (walk (vector-ref obj i)))))))))
    (hash-table-walk
     tab
     (lambda (obj count)
       (if (> count 1)
           (begin
             (eq?-table-set! res obj (cons index #f))
             (set! index (+ index 1))))))
    res))

(define (gen-shared-ref i suffix)
  (string-append "#" (number->string i) suffix))

(define (maybe-gen-shared-ref st cell shares)
  (cond
    ((pair? cell)
     (set-car! cell (cdr shares))
     (set-cdr! cell #t)
     (set-cdr! shares (+ (cdr shares) 1))
     ((fmt-writer st) (gen-shared-ref (car cell) "=") st))
    (else st)))

(define (call-with-shared-ref obj st shares proc)
  (let ((cell (eq?-table-ref (car shares) obj)))
    (if (and (pair? cell) (cdr cell))
        ((fmt-writer st) (gen-shared-ref (car cell) "#") st)
        (proc (maybe-gen-shared-ref st cell shares)))))

(define (call-with-shared-ref/cdr obj st shares proc sep)
  (let ((cell (eq?-table-ref (car shares) obj))
        (output (fmt-writer st)))
    (cond
      ((and (pair? cell) (cdr cell))
       (output (gen-shared-ref (car cell) "#") (output ". " (sep st))))
      ((pair? cell)
       (let ((st (maybe-gen-shared-ref (output ". " (sep st)) cell shares)))
         (output ")" (proc (output "(" st)))))
      (else
       (proc (sep st))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; sexp formatters

(define (slashified str . o)
  (let-optionals* o ((quot #\") (esc #\\) (rename (lambda (x) #f)))
    (lambda (st)
      (let* ((len (string-length str))
             (output (fmt-writer st))
             (quot-str (string quot))
             (esc-str (if (char? esc) (string esc) (or esc quot-str))))
        (let lp ((i 0) (j 0) (st st))
          (define (collect)
            (if (= i j) st (output (substring/shared str i j) st)))
          (if (>= j len)
              (collect)
              (let ((c (string-ref str j)))
                (cond
                  ((or (eqv? c quot) (eqv? c esc))
                   (lp j (+ j 1) (output esc-str (collect))))
                  ((rename c)
                   => (lambda (c2)
                        (lp (+ j 1)
                            (+ j 1)
                            (output c2 (output esc-str (collect))))))
                  (else
                   (lp i (+ j 1) st))))))))))

;; Only slashify if there are special characters, in which case also
;; wrap in quotes.  For writing symbols in |...| escapes, or CSV
;; fields, etc.  The predicate indicates which characters cause
;; slashification - this is in addition to automatic slashifying when
;; either the quote or escape char is present.

(define (maybe-slashified str pred . o)
  (let-optionals* o ((quot #\") (esc #\\) (rename (lambda (x) #f)))
    (define (esc? c) (or (eqv? c quot) (eqv? c esc) (rename c) (pred c)))
    (if (string-index str esc?)
        (cat quot (slashified str quot esc rename) quot)
        (dsp str))))

(define (fmt-write-string str)
  (define (rename c)
    (case c
      ((#\newline) "n")
      (else #f)))
  (slashified str #\" #\\ rename))

(define (dsp obj)
  (cond
    ((procedure? obj) obj)
    ((string? obj) (lambda (st) ((fmt-writer st) obj st)))
    ((char? obj) (dsp (string obj)))
    (else (wrt obj))))

(define (write-with-shares obj shares)
  (lambda (st)
    (let* ((output (fmt-writer st))
           (wr-num
            (cond ((and (= 10 (fmt-radix st))
                        (not (fmt-precision st)))
                   (lambda (n st) (output (number->string n) st)))
                  ((assv (fmt-radix st)
                         '((16 . "#x") (10 . "") (8 . "#o") (2 . "#b")))
                   => (lambda (cell)
                        (let ((prefix (cdr cell)))
                          (lambda (n st) ((num n) (output prefix st))))))
                  (else (lambda (n st) (output (number->string n) st))))))
      (let wr ((obj obj) (st st))
        (call-with-shared-ref obj st shares
          (lambda (st)
            (cond
              ((pair? obj)
               (output
                ")"
                (let lp ((ls obj)
                         (st (output "(" st)))
                  (let ((st (wr (car ls) st))
                        (rest (cdr ls)))
                    (cond
                      ((null? rest) st)
                      ((pair? rest)
                       (call-with-shared-ref/cdr rest st shares
                         (lambda (st) (lp rest st))
                         (dsp " ")))
                      (else (wr rest (output " . " st))))))))
              ((vector? obj)
               (let ((len (vector-length obj)))
                 (if (zero? len)
                     (output "#()" st)
                     (let lp ((i 1)
                              (st
                               (wr (vector-ref obj 0)
                                   (output "#(" st))))
                       (if (>= i len)
                           (output ")" st)
                           (lp (+ i 1)
                               (wr (vector-ref obj i)
                                   (output " " st))))))))
              ((string? obj)
               (output "\"" ((fmt-write-string obj) (output "\"" st))))
              ((number? obj)
               (wr-num obj st))
              ((boolean? obj)
               (output (if obj "#t" "#f") st))
              (else
               (output (write-to-string obj) st)))))))))

(define (wrt obj)
  (write-with-shares obj (cons (make-shared-ref-table obj) 0)))

;; the only expensive part, in both time and memory, of handling
;; shared structures when writing is building the initial table, so
;; for the efficient version we just skip that

(define (wrt/unshared obj)
  (write-with-shares obj (cons (make-eq?-table) 0)))


[-- Attachment #6: let-optionals.scm --]
[-- Type: application/octet-stream, Size: 1203 bytes --]


;; (define-syntax let-optionals*
;;   (syntax-rules ()
;;     ((_ opt-ls () body ...)
;;      (let () body ...))
;;     ((_ (expr ...) vars body ...)
;;      (let ((tmp (expr ...)))
;;        (let-optionals* tmp vars body ...)))
;;     ((_ tmp ((var default) . rest) body ...)
;;      (let ((var (if (pair? tmp) (car tmp) default))
;;            (tmp2 (if (pair? tmp) (cdr tmp) '())))
;;        (let-optionals* tmp2 rest body ...)))
;;     ((_ tmp tail body ...)
;;      (let ((tail tmp))
;;        body ...))
;;     ))

(define-syntax let-optionals*
  (syntax-rules ()
    ((_ opt-ls () . body)
     (let () . body))
    ((_ (op . args) vars . body)
     (let ((tmp (op . args)))
       (let-optionals* tmp vars . body)))
    ((_ tmp ((var default) . rest) . body)
     (let ((var (if (pair? tmp) (car tmp) default))
           (tmp2 (if (pair? tmp) (cdr tmp) '())))
       (let-optionals* tmp2 rest . body)))
    ((_ tmp tail . body)
     (let ((tail tmp))
       . body))
    ))

;; (define-syntax let-optionals*
;;   (syntax-rules ()
;;     ((_ opts ((var default) ...) body ...)
;;      (let* ((var (if (memq 'var opts) (cadr (memq 'var opts)) default))
;;             ...)
;;        body ...))))

[-- Attachment #7: make-eq-table.scm --]
[-- Type: application/octet-stream, Size: 51 bytes --]


(define (make-eq?-table)
  (make-hash-table eq?))

[-- Attachment #8: mantissa.scm --]
[-- Type: application/octet-stream, Size: 616 bytes --]


;; Break a positive real number down to a normalized mantissa and
;; exponent. Default base=2, mant-size=52, exp-size=11 for IEEE doubles.

(define (mantissa+exponent num . opt)
  (if (zero? num)
      (list 0 0)
      (let-optionals* opt ((base 2) (mant-size 52) (exp-size 11))
        (let* ((bot (expt base mant-size))
               (top (* base bot)))
          (let lp ((n num) (e 0))
            (cond
              ((>= n top) (lp (quotient n base) (+ e 1)))
              ((< n bot) (lp (* n base) (- e 1)))
              (else (list (inexact->exact n)
                          (inexact->exact e)))))))))

[-- Attachment #9: test-fmt.scm --]
[-- Type: application/octet-stream, Size: 14452 bytes --]

(use-modules (srfi srfi-26))

(define-syntax truncated-written-exp
  (syntax-rules ()
    ((_ expr)
     (let ((s (with-output-to-string (lambda () (write 'expr)))))
               (substring s 0 (min 60 (string-length s)))))))

(cond-expand
 (chicken (use test fmt))
 (gauche
  (use gauche.test)
  (use text.fmt)
  (define test-begin test-start)
  (define orig-test (with-module gauche.test test))
  (define-syntax test
    (syntax-rules ()
      ((test name expected expr)
       (orig-test name expected (lambda () expr)))
      ((test expected expr)
       (orig-test (let ((s (with-output-to-string (lambda () (write 'expr)))))
                    (substring s 0 (min 60 (string-length s))))
                  expected
                  (lambda () expr)))
      )))
 (guile
  (use-modules (test-suite lib))
  (define (test-begin name) (simple-format #t "Testing ~A\n" name))
  (define (test-end) #t)
  (define-syntax test
    (syntax-rules ()
      ((test name expected expr)
       (pass-if name (equal? expected expr)))
      ((test expected expr)
       (test (truncated-written-exp expr)
             expected
             expr))))
  (define-syntax test-error
    (syntax-rules ()
      ((test-error expr)
       (pass-if-exception
        (truncated-written-exp expr)
        exception:miscellaneous-error
        expr)))))
 (else))

(test-begin "fmt")

;; basic data types

(test "hi" (fmt #f "hi"))
(test "\"hi\"" (fmt #f (wrt "hi")))
(test "\"hi \\\"bob\\\"\"" (fmt #f (wrt "hi \"bob\"")))
(test "\"hello\\nworld\"" (fmt #f (wrt "hello\nworld")))
(test "ABC" (fmt #f (upcase "abc")))
(test "abc" (fmt #f (downcase "ABC")))
(test "Abc" (fmt #f (titlecase "abc")))

(test "abc     def" (fmt #f "abc" (tab-to) "def"))
(test "abc  def" (fmt #f "abc" (tab-to 5) "def"))
(test "abcdef" (fmt #f "abc" (tab-to 3) "def"))

(test "-1" (fmt #f -1))
(test "0" (fmt #f 0))
(test "1" (fmt #f 1))
(test "10" (fmt #f 10))
(test "100" (fmt #f 100))
;; (test "1e+15" (fmt #f 1e+15))
;; (test "1e+23" (fmt #f 1e+23))
;; (test "1.2e+23" (fmt #f 1.2e+23))
;; (test "1e-5" (fmt #f 1e-5))
;; (test "1e-6" (fmt #f 1e-6))
;; (test "1e-7" (fmt #f 1e-7))
;; (test "2e-6" (fmt #f 2e-6))
(test "57005" (fmt #f #xDEAD))
(test "#xDEAD" (fmt #f (radix 16 #xDEAD)))
(test "#xDEAD1234" (fmt #f (radix 16 #xDEAD) 1234))
(test "#xDE.AD" (fmt #f (radix 16 (exact->inexact (/ #xDEAD #x100)))))
(test "#xD.EAD" (fmt #f (radix 16 (exact->inexact (/ #xDEAD #x1000)))))
(test "#x0.DEAD" (fmt #f (radix 16 (exact->inexact (/ #xDEAD #x10000)))))
(test "1G" (fmt #f (radix 17 (num 33))))
(test "1G" (fmt #f (num 33 17)))

(test "3.14159" (fmt #f 3.14159))
(test "3.14" (fmt #f (fix 2 3.14159)))
(test "3.14" (fmt #f (fix 2 3.14)))
(test "3.00" (fmt #f (fix 2 3.)))
(test "1.10" (fmt #f (num 1.099 10 2)))
(test "0.00" (fmt #f (fix 2 1e-17)))
(test "0.0000000000" (fmt #f (fix 10 1e-17)))
(test "0.00000000000000001000" (fmt #f (fix 20 1e-17)))
(test-error (fmt #f (num 1e-17 0)))

(test "11.75" (fmt #f (num (/ 47 4) 10 2)))
(test "-11.75" (fmt #f (num (/ -47 4) 10 2)))

(test "(#x11 #x22 #x33)" (fmt #f (radix 16 '(#x11 #x22 #x33))))

(test "299,792,458" (fmt #f (num 299792458 10 #f #f #t)))
(test "299,792,458" (fmt #f (num/comma 299792458)))
(test "299.792.458" (fmt #f (comma-char #\. (num/comma 299792458))))
(test "299.792.458,0" (fmt #f (comma-char #\. (num/comma 299792458.0))))

(test "100,000" (fmt #f (num 100000 10 0 #f 3)))
(test "100,000.0" (fmt #f (num 100000 10 1 #f 3)))
(test "100,000.00" (fmt #f (num 100000 10 2 #f 3)))

(test "1.23" (fmt #f (fix 2 (num/fit 4 1.2345))))
(test "1.00" (fmt #f (fix 2 (num/fit 4 1))))
(test "#.##" (fmt #f (fix 2 (num/fit 4 12.345))))

(cond
 ((feature? 'full-numeric-tower)
  (test "1+2i" (fmt #f (string->number "1+2i")))
  (test "1+2i" (fmt #f (num (string->number "1+2i"))))
  (test "1.00+2.00i" (fmt #f (fix 2 (num (string->number "1+2i")))))
  (test "3.14+2.00i" (fmt #f (fix 2 (num (string->number "3.14159+2i")))))))

(test "3.9Ki" (fmt #f (num/si 3986)))
(test "4k" (fmt #f (num/si 3986 1000)))
(test "608" (fmt #f (num/si 608)))
(test "3G" (fmt #f (num/si 12345.12355 16)))

;; padding/trimming

(test "abc  " (fmt #f (pad 5 "abc")))
(test "  abc" (fmt #f (pad/left 5 "abc")))
(test " abc " (fmt #f (pad/both 5 "abc")))
(test "abcde" (fmt #f (pad 5 "abcde")))
(test "abcdef" (fmt #f (pad 5 "abcdef")))

(test "abc" (fmt #f (trim 3 "abcde")))
(test "abc" (fmt #f (trim/length 3 "abcde")))
(test "abc" (fmt #f (trim/length 3 "abc\nde")))
(test "cde" (fmt #f (trim/left 3 "abcde")))
(test "bcd" (fmt #f (trim/both 3 "abcde")))

(test "prefix: abc" (fmt #f "prefix: " (trim 3 "abcde")))
(test "prefix: abc" (fmt #f "prefix: " (trim/length 3 "abcde")))
(test "prefix: abc" (fmt #f "prefix: " (trim/length 3 "abc\nde")))
(test "prefix: cde" (fmt #f "prefix: " (trim/left 3 "abcde")))
(test "prefix: bcd" (fmt #f "prefix: " (trim/both 3 "abcde")))

(test "abcde" (fmt #f (ellipses "..." (trim 5 "abcde"))))
(test "ab..." (fmt #f (ellipses "..." (trim 5 "abcdef"))))
(test "abc..." (fmt #f (ellipses "..." (trim 6 "abcdefg"))))
(test "abcde" (fmt #f (ellipses "..." (trim/left 5 "abcde"))))
(test "...ef" (fmt #f (ellipses "..." (trim/left 5 "abcdef"))))
(test "...efg" (fmt #f (ellipses "..." (trim/left 6 "abcdefg"))))
(test "abcdefg" (fmt #f (ellipses "..." (trim/both 7 "abcdefg"))))
(test "...d..." (fmt #f (ellipses "..." (trim/both 7 "abcdefgh"))))
(test "...e..." (fmt #f (ellipses "..." (trim/both 7 "abcdefghi"))))

(test "abc  " (fmt #f (fit 5 "abc")))
(test "  abc" (fmt #f (fit/left 5 "abc")))
(test " abc " (fmt #f (fit/both 5 "abc")))
(test "abcde" (fmt #f (fit 5 "abcde")))
(test "abcde" (fmt #f (fit/left 5 "abcde")))
(test "abcde" (fmt #f (fit/both 5 "abcde")))
(test "abcde" (fmt #f (fit 5 "abcdefgh")))
(test "defgh" (fmt #f (fit/left 5 "abcdefgh")))
(test "cdefg" (fmt #f (fit/both 5 "abcdefgh")))

(test "prefix: abc  " (fmt #f "prefix: " (fit 5 "abc")))
(test "prefix:   abc" (fmt #f "prefix: " (fit/left 5 "abc")))
(test "prefix:  abc " (fmt #f "prefix: " (fit/both 5 "abc")))
(test "prefix: abcde" (fmt #f "prefix: " (fit 5 "abcde")))
(test "prefix: abcde" (fmt #f "prefix: " (fit/left 5 "abcde")))
(test "prefix: abcde" (fmt #f "prefix: " (fit/both 5 "abcde")))
(test "prefix: abcde" (fmt #f "prefix: " (fit 5 "abcdefgh")))
(test "prefix: defgh" (fmt #f "prefix: " (fit/left 5 "abcdefgh")))
(test "prefix: cdefg" (fmt #f "prefix: " (fit/both 5 "abcdefgh")))

(test "abc\n123\n" (fmt #f (fmt-join/suffix (cut trim 3 <>) '("abcdef" "123456") nl)))

;; utilities

(test "1 2 3" (fmt #f (fmt-join dsp '(1 2 3) " ")))

;; shared structures

(test "#0=(1 . #0#)"
    (fmt #f (wrt (let ((ones (list 1))) (set-cdr! ones ones) ones))))
(test "(0 . #0=(1 . #0#))"
    (fmt #f (wrt (let ((ones (list 1)))
                   (set-cdr! ones ones)
                   (cons 0 ones)))))
(test "(sym . #0=(sym . #0#))"
    (fmt #f (wrt (let ((syms (list 'sym)))
                   (set-cdr! syms syms)
                   (cons 'sym syms)))))
(test "(#0=(1 . #0#) #1=(2 . #1#))"
    (fmt #f (wrt (let ((ones (list 1))
                       (twos (list 2)))
                   (set-cdr! ones ones)
                   (set-cdr! twos twos)
                   (list ones twos)))))

;; without shared detection

(test "(1 1 1 1 1"
    (fmt #f (trim/length
             10
             (wrt/unshared
              (let ((ones (list 1))) (set-cdr! ones ones) ones)))))

(test "(1 1 1 1 1 "
    (fmt #f (trim/length
             11
             (wrt/unshared
              (let ((ones (list 1))) (set-cdr! ones ones) ones)))))

;; pretty printing

(define-macro (test-pretty str)
  (let ((sexp (with-input-from-string str read)))
    `(test ,str (fmt #f (pretty ',sexp)))))

(test-pretty "(foo bar)\n")

(test-pretty
"((self . aquanet-paper-1991)
 (type . paper)
 (title . \"Aquanet: a hypertext tool to hold your\"))
")

(test-pretty
"(abracadabra xylophone
             bananarama
             yellowstonepark
             cryptoanalysis
             zebramania
             delightful
             wubbleflubbery)\n")

(test-pretty
 "#(0  1  2  3  4  5  6  7  8  9  10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
   25 26 27 28 29 30 31 32 33 34 35 36 37)\n")

(test-pretty
 "(0  1  2  3  4  5  6  7  8  9  10 11 12 13 14 15 16 17 18 19 20 21 22 23 24
  25 26 27 28 29 30 31 32 33 34 35 36 37)\n")

(test-pretty
 "(define (fold kons knil ls)
  (define (loop ls acc)
    (if (null? ls) acc (loop (cdr ls) (kons (car ls) acc))))
  (loop ls knil))\n")

(test-pretty
"(do ((vec (make-vector 5)) (i 0 (+ i 1))) ((= i 5) vec) (vector-set! vec i i))\n")

(test-pretty
"(do ((vec (make-vector 5)) (i 0 (+ i 1))) ((= i 5) vec)
  (vector-set! vec i 'supercalifrajalisticexpialidocious))\n")

(test-pretty
"(do ((my-vector (make-vector 5)) (index 0 (+ index 1)))
    ((= index 5) my-vector)
  (vector-set! my-vector index index))\n")

(test-pretty
 "(define (fold kons knil ls)
  (let loop ((ls ls) (acc knil))
    (if (null? ls) acc (loop (cdr ls) (kons (car ls) acc)))))\n")

(test-pretty
 "(define (file->sexp-list pathname)
  (call-with-input-file pathname
    (lambda (port)
      (let loop ((res '()))
        (let ((line (read port)))
          (if (eof-object? line) (reverse res) (loop (cons line res))))))))\n")

(test "(let ((ones '#0=(1 . #0#))) ones)\n"
    (fmt #f (pretty (let ((ones (list 1))) (set-cdr! ones ones) `(let ((ones ',ones)) ones)))))

'(test
"(let ((zeros '(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
      (ones '#0=(1 . #0#)))
  (append zeros ones))\n"
    (fmt #f (pretty
             (let ((ones (list 1)))
               (set-cdr! ones ones)
               `(let ((zeros '(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
                      (ones ',ones))
                  (append zeros ones))))))

;; slashify

(test "\"note\",\"very simple\",\"csv\",\"writer\",\"\"\"yay!\"\"\""
    (fmt #f (fmt-join (lambda (x) (cat "\"" (slashified x #\" #f) "\""))
                  '("note" "very simple" "csv" "writer" "\"yay!\"")
                  ",")))

(test "note,\"very simple\",csv,writer,\"\"\"yay!\"\"\""
    (fmt #f (fmt-join (cut maybe-slashified <> char-whitespace? #\" #f)
                  '("note" "very simple" "csv" "writer" "\"yay!\"")
                  ",")))

;; columnar formatting

(test "abc\ndef\n" (fmt #f (fmt-columns (list dsp "abc\ndef\n"))))
(test "abc123\ndef456\n" (fmt #f (fmt-columns (list dsp "abc\ndef\n") (list dsp "123\n456\n"))))
(test "abc123\ndef456\n" (fmt #f (fmt-columns (list dsp "abc\ndef\n") (list dsp "123\n456"))))
(test "abc123\ndef456\n" (fmt #f (fmt-columns (list dsp "abc\ndef") (list dsp "123\n456\n"))))
(test "abc123\ndef456\nghi789\n"
    (fmt #f (fmt-columns (list dsp "abc\ndef\nghi\n") (list dsp "123\n456\n789\n"))))
(test "abc123wuv\ndef456xyz\n"
    (fmt #f (fmt-columns (list dsp "abc\ndef\n") (list dsp "123\n456\n") (list dsp "wuv\nxyz\n"))))
(test "abc  123\ndef  456\n"
    (fmt #f (fmt-columns (list (cut pad/right 5 <>) "abc\ndef\n") (list dsp "123\n456\n"))))
(test "ABC  123\nDEF  456\n"
    (fmt #f (fmt-columns (list (compose upcase (cut pad/right 5 <>)) "abc\ndef\n")
                         (list dsp "123\n456\n"))))
(test "ABC  123\nDEF  456\n"
    (fmt #f (fmt-columns (list (compose (cut pad/right 5 <>) upcase) "abc\ndef\n")
                         (list dsp "123\n456\n"))))

(test "hello\nworld\n" (fmt #f (with-width 8 (wrap-lines "hello world"))))

(test "The fundamental list iterator.
Applies KONS to each element of
LS and the result of the previous
application, beginning with KNIL.
With KONS as CONS and KNIL as '(),
equivalent to REVERSE.
"
    (fmt #f (with-width 36 (wrap-lines "The fundamental list iterator.  Applies KONS to each element of LS and the result of the previous application, beginning with KNIL.  With KONS as CONS and KNIL as '(), equivalent to REVERSE."))))

(test
"The   fundamental   list   iterator.
Applies  KONS  to  each  element  of
LS  and  the  result of the previous
application,  beginning  with  KNIL.
With  KONS  as CONS and KNIL as '(),
equivalent to REVERSE.
"
    (fmt #f (with-width 36 (justify "The fundamental list iterator.  Applies KONS to each element of LS and the result of the previous application, beginning with KNIL.  With KONS as CONS and KNIL as '(), equivalent to REVERSE."))))

(test
"(define (fold kons knil ls)          ; The fundamental list iterator.
  (let lp ((ls ls) (acc knil))       ; Applies KONS to each element of
    (if (null? ls)                   ; LS and the result of the previous
        acc                          ; application, beginning with KNIL.
        (lp (cdr ls)                 ; With KONS as CONS and KNIL as '(),
            (kons (car ls) acc)))))  ; equivalent to REVERSE.
"
    (fmt #f (fmt-columns
             (list
              (cut pad/right 36 <>)
              (with-width 36
                (pretty '(define (fold kons knil ls)
                           (let lp ((ls ls) (acc knil))
                             (if (null? ls)
                                 acc
                                 (lp (cdr ls)
                                     (kons (car ls) acc))))))))
             (list
              (cut cat " ; " <>)
              (with-width 36
                (wrap-lines "The fundamental list iterator.  Applies KONS to each element of LS and the result of the previous application, beginning with KNIL.  With KONS as CONS and KNIL as '(), equivalent to REVERSE."))))))

(test
"(define (fold kons knil ls)          ; The fundamental list iterator.
  (let lp ((ls ls) (acc knil))       ; Applies KONS to each element of
    (if (null? ls)                   ; LS and the result of the previous
        acc                          ; application, beginning with KNIL.
        (lp (cdr ls)                 ; With KONS as CONS and KNIL as '(),
            (kons (car ls) acc)))))  ; equivalent to REVERSE.
"
    (fmt #f (with-width 76
              (columnar
               (pretty '(define (fold kons knil ls)
                          (let lp ((ls ls) (acc knil))
                            (if (null? ls)
                                acc
                                (lp (cdr ls)
                                    (kons (car ls) acc))))))
               " ; "
               (wrap-lines "The fundamental list iterator.  Applies KONS to each element of LS and the result of the previous application, beginning with KNIL.  With KONS as CONS and KNIL as '(), equivalent to REVERSE.")))))

(test-end)


^ permalink raw reply	[flat|nested] 13+ messages in thread

end of thread, other threads:[~2011-03-27 23:24 UTC | newest]

Thread overview: 13+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2011-03-12 21:14 Fmt Module Noah Lavine
2011-03-13 21:37 ` Andreas Rottmann
2011-03-14  3:54   ` Noah Lavine
2011-03-14 17:16   ` Ludovic Courtès
2011-03-14 17:35     ` Klaus Schilling
2011-03-27 11:07       ` Andy Wingo
2011-03-24  0:45     ` Andreas Rottmann
2011-03-24 21:14       ` Ludovic Courtès
2011-03-26 14:03         ` Andreas Rottmann
2011-03-27 14:01           ` Ludovic Courtès
2011-03-27 11:10     ` Andy Wingo
2011-03-27 15:38       ` Noah Lavine
2011-03-27 23:24         ` Andreas Rottmann

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).