* 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* Re: Fmt Module
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
0 siblings, 2 replies; 13+ messages in thread
From: Andreas Rottmann @ 2011-03-13 21:37 UTC (permalink / raw)
To: Noah Lavine; +Cc: guile-devel
[-- Attachment #1: Type: text/plain, Size: 2842 bytes --]
Noah Lavine <noah.b.lavine@gmail.com> writes:
> 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/.
>
Not that I have any say in that, but IMHO, it would be preferable to
keep external libraries maintained separatly from the Guile core;
however in this case, including it in the core might be justified by its
proposed use in the JIT compiler.
FWIW, there's already an R6RS adaption of "fmt"[1] as part of the Wak
project[0], which works nicely with Guile (from the stable-2.0 branch).
[0] http://home.gna.org/wak/
[1] http://gitorious.org/wak/wak-fmt
> It looks like a nice formatting library,
>
Indeed!
> and I imagine it would be useful to people who want to generate html
> for the web module.
>
For that, I'd rather suggest building up SXML and use SSAX[2] or
HtmlPrag[3] for serialization.
[2] http://ssax.sourceforge.net/
[3] http://www.neilvandyke.org/htmlprag/
> 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.
>
Yeah, that makes sense.
> (I'm only attaching the basic library right now, but I hope to package
> up the C formatting stuff soon.)
>
Well, the Wak adaption has this stuff already done ;-).
> 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.
>
Having a quick glance at the code, I think you should refrain from using
`load', and use `include' instead (it seems that the latter is
undocumented, unfortunatly). Also, it should not be necessary to `load'
any file before doing `(use-modules (fmt fmt))' -- the latter should be
enough if the code is organized appropriatly (i.e. files placed into the
right directories). You might want to have a look at how the R6RS port
is organized (see the git repo at [1]).
> 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.
>
Could you produce a diff? FWIW, I've attached the changes in the Wak
adaption -- there are only differences in the test suite, which uses
some implementation-specifics, and also `cond-expand' which is not
available on Racket (which is one of the implementations targetet by
Wak). I've not yet bothered to submit those upstream, since I assume
they would not be accepted, as they (a) disable some tests that rely on
implementation-specific extensions (b) probably break on the author's
system.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: +changes-0.7.diff --]
[-- Type: text/x-diff, Size: 5189 bytes --]
Only in .: +changes-0.7.diff
Only in /home/rotty/src/_readonly/fmt-0.7/: .hgignore
Only in /home/rotty/src/_readonly/fmt-0.7/: Makefile
Only in /home/rotty/src/_readonly/fmt-0.7/: README
Only in /home/rotty/src/_readonly/fmt-0.7/: VERSION
Only in /home/rotty/src/_readonly/fmt-0.7/: fmt
Only in /home/rotty/src/_readonly/fmt-0.7/: fmt-c-chicken.scm
Only in /home/rotty/src/_readonly/fmt-0.7/: fmt-c-gauche.scm
Only in /home/rotty/src/_readonly/fmt-0.7/: fmt-c-mzscheme.scm
Only in /home/rotty/src/_readonly/fmt-0.7/: fmt-chicken.scm
Only in /home/rotty/src/_readonly/fmt-0.7/: fmt-color-chicken.scm
Only in /home/rotty/src/_readonly/fmt-0.7/: fmt-color-gauche.scm
Only in /home/rotty/src/_readonly/fmt-0.7/: fmt-color-mzscheme.scm
Only in /home/rotty/src/_readonly/fmt-0.7/: fmt-gauche.scm
Only in /home/rotty/src/_readonly/fmt-0.7/: fmt-mzscheme.scm
Only in /home/rotty/src/_readonly/fmt-0.7/: fmt-scheme48.scm
Only in /home/rotty/src/_readonly/fmt-0.7/: fmt-unicode-chicken.scm
Only in /home/rotty/src/_readonly/fmt-0.7/: fmt-unicode-gauche.scm
Only in /home/rotty/src/_readonly/fmt-0.7/: fmt-unicode-mzscheme.scm
Only in /home/rotty/src/_readonly/fmt-0.7/: fmt.css
Only in /home/rotty/src/_readonly/fmt-0.7/: fmt.html
Only in /home/rotty/src/_readonly/fmt-0.7/: fmt.meta
Only in /home/rotty/src/_readonly/fmt-0.7/: fmt.mistie
Only in /home/rotty/src/_readonly/fmt-0.7/: fmt.setup
Only in /home/rotty/src/_readonly/fmt-0.7/: let-optionals.scm
Only in /home/rotty/src/_readonly/fmt-0.7/: make-eq-table.scm
Only in /home/rotty/src/_readonly/fmt-0.7/: read-line.scm
Only in /home/rotty/src/_readonly/fmt-0.7/: srfi-33.scm
Only in /home/rotty/src/_readonly/fmt-0.7/: srfi-69.scm
Only in /home/rotty/src/_readonly/fmt-0.7/: string-ports.scm
diff -bur /home/rotty/src/_readonly/fmt-0.7//test-fmt.scm ./test-fmt.scm
--- /home/rotty/src/_readonly/fmt-0.7//test-fmt.scm 2009-10-11 10:04:55.000000000 +0200
+++ ./test-fmt.scm 2010-04-12 11:03:16.000000000 +0200
@@ -1,21 +1,20 @@
-(cond-expand
- (chicken (use test) (load "fmt-chicken.scm"))
- (gauche
- (use gauche.test)
- (use text.fmt)
- (define test-begin test-start)
- (define orig-test (with-module gauche.test test))
- (define-syntax test
+(define-syntax test
(syntax-rules ()
- ((test name expected expr)
- (guard (e (else #f))
- (orig-test name expected (lambda () expr))))
((test expected expr)
- (test (let ((s (with-output-to-string (lambda () (write 'expr)))))
- (substring s 0 (min 60 (string-length s))))
- expected expr)))))
- (else))
+ (test-equal expected expr))))
+
+;; pretty printing
+
+;; (define-macro (test-pretty str)
+;; (let ((sexp (with-input-from-string str read)))
+;; `(test ,str (fmt #f (pretty ',sexp)))))
+
+(define-syntax test-pretty
+ (syntax-rules ()
+ ((test-pretty str)
+ (let ((sexp (call-with-string-input-port str read)))
+ (test str (fmt #f (pretty sexp)))))))
(test-begin "fmt")
@@ -123,12 +122,10 @@
(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 "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)))
@@ -185,7 +182,7 @@
(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 <>) (string-split "abcdef\n123456\n" "\n") nl)))
+(test "abc\n123\n" (fmt #f (fmt-join (cut trim 3 <>) (string-split "abcdef\n123456\n" "\n") nl)))
;; utilities
@@ -224,18 +221,6 @@
(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)))))
-
-(define-syntax test-pretty
- (syntax-rules ()
- ((test-pretty str)
- (let ((sexp (with-input-from-string str read)))
- (test str (fmt #f (pretty sexp)))))))
-
(test-pretty "(foo bar)\n")
(test-pretty
@@ -422,22 +407,24 @@
;; misc extras
+#;
(define (string-hide-passwords str)
(string-substitute (regexp "(pass(?:w(?:or)?d)?\\s?[:=>]\\s+)\\S+" #t)
"\\1******"
str
#t))
-
+#;
(define hide-passwords
(make-string-fmt-transformer string-hide-passwords))
+#;
(define (string-mangle-email str)
(string-substitute
(regexp "\\b([-+.\\w]+)@((?:[-+\\w]+\\.)+[a-z]{2,4})\\b" #t)
"\\1 _at_ \\2"
str
#t))
-
+#;
(define mangle-email
(make-string-fmt-transformer string-mangle-email))
[-- Attachment #3: Type: text/plain, Size: 63 bytes --]
Regards, Rotty
--
Andreas Rottmann -- <http://rotty.yi.org/>
^ permalink raw reply [flat|nested] 13+ messages in thread* Re: Fmt Module
2011-03-13 21:37 ` Andreas Rottmann
@ 2011-03-14 3:54 ` Noah Lavine
2011-03-14 17:16 ` Ludovic Courtès
1 sibling, 0 replies; 13+ messages in thread
From: Noah Lavine @ 2011-03-14 3:54 UTC (permalink / raw)
To: Andreas Rottmann; +Cc: guile-devel
Hi,
> Not that I have any say in that, but IMHO, it would be preferable to
> keep external libraries maintained separatly from the Guile core;
> however in this case, including it in the core might be justified by its
> proposed use in the JIT compiler.
Yeah. I agree, actually.
> FWIW, there's already an R6RS adaption of "fmt"[1] as part of the Wak
> project[0], which works nicely with Guile (from the stable-2.0 branch).
Oh, I didn't realize that. We should certainly use that, then. I'll
try to take a look at it soon, if I have time.
Noah
^ permalink raw reply [flat|nested] 13+ messages in thread
* Re: Fmt Module
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
` (2 more replies)
1 sibling, 3 replies; 13+ messages in thread
From: Ludovic Courtès @ 2011-03-14 17:16 UTC (permalink / raw)
To: guile-devel
Hello,
Andreas Rottmann <a.rottmann@gmx.at> writes:
> Not that I have any say in that, but IMHO, it would be preferable to
> keep external libraries maintained separatly from the Guile core;
> however in this case, including it in the core might be justified by its
> proposed use in the JIT compiler.
When we do include external libs, we should strive to leave upstream
files unmodified, as is done for (sxml ssax), (system base lalr),
(ice-9 match), and others.
I think it would make sense to include ‘fmt’ in core Guile only if the
API is reasonably stable and there are infrequent upstream releases, so
we don’t quickly end up shipping an old incompatible version.
Thoughts?
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 13+ messages in thread* Re: Fmt Module
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-27 11:10 ` Andy Wingo
2 siblings, 1 reply; 13+ messages in thread
From: Klaus Schilling @ 2011-03-14 17:35 UTC (permalink / raw)
To: ludo; +Cc: guile-devel
From: ludo@gnu.org (Ludovic Courtès)
Subject: Re: Fmt Module
Date: Mon, 14 Mar 2011 18:16:17 +0100
>
> When we do include external libs, we should strive to leave upstream
> files unmodified, as is done for (sxml ssax), (system base lalr),
> (ice-9 match), and others.
Why does htmlprag not get included?
Klaus Schilling
^ permalink raw reply [flat|nested] 13+ messages in thread
* Re: Fmt Module
2011-03-14 17:35 ` Klaus Schilling
@ 2011-03-27 11:07 ` Andy Wingo
0 siblings, 0 replies; 13+ messages in thread
From: Andy Wingo @ 2011-03-27 11:07 UTC (permalink / raw)
To: Klaus Schilling; +Cc: ludo, guile-devel
On Mon 14 Mar 2011 18:35, Klaus Schilling <schilling.klaus@web.de> writes:
> From: ludo@gnu.org (Ludovic Courtès)
> Subject: Re: Fmt Module
> Date: Mon, 14 Mar 2011 18:16:17 +0100
>>
>> When we do include external libs, we should strive to leave upstream
>> files unmodified, as is done for (sxml ssax), (system base lalr),
>> (ice-9 match), and others.
>
> Why does htmlprag not get included?
Because it's not used by Guile itself, unlike the sxml stuff, statprof,
lalr, the matchers or the texinfo code. Likewise, and more topically, I
would be inclined to include `fmt' iff we want to use it in Guile
itself.
You can install htmlprag from Guile-Lib; version 0.2.0 was released
yesterday.
I assume your broader point is that you would like it to be easier to
install htmlprag. The CPAN for guile should fill that nice nicely.
Regards,
Andy
--
http://wingolog.org/
^ permalink raw reply [flat|nested] 13+ messages in thread
* Re: Fmt Module
2011-03-14 17:16 ` Ludovic Courtès
2011-03-14 17:35 ` Klaus Schilling
@ 2011-03-24 0:45 ` Andreas Rottmann
2011-03-24 21:14 ` Ludovic Courtès
2011-03-27 11:10 ` Andy Wingo
2 siblings, 1 reply; 13+ messages in thread
From: Andreas Rottmann @ 2011-03-24 0:45 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: guile-devel
ludo@gnu.org (Ludovic Courtès) writes:
> Hello,
>
> Andreas Rottmann <a.rottmann@gmx.at> writes:
>
>> Not that I have any say in that, but IMHO, it would be preferable to
>> keep external libraries maintained separatly from the Guile core;
>> however in this case, including it in the core might be justified by its
>> proposed use in the JIT compiler.
>
> When we do include external libs, we should strive to leave upstream
> files unmodified, as is done for (sxml ssax), (system base lalr),
> (ice-9 match), and others.
>
As I already mentioned, the Wak adaption of `fmt' does not modify
upstream files (except for the test suite); it is just adding library
definition files that include the upstream files. As wak-fmt seems to
work nicely on Guile, I see no problem here.
> I think it would make sense to include ‘fmt’ in core Guile only if the
> API is reasonably stable and there are infrequent upstream releases, so
> we don’t quickly end up shipping an old incompatible version.
>
I think `fmt' qualifies these criteria.
However, even if I think based on your criteria nothing speaks against
including fmt in Guile, there is still the argument of code duplication:
if some external library (e.g., conjure) makes use of wak-fmt and
another chooses the version included in Guile, a third program/library
can't make use of both of these without ending up with two copies of the
`fmt' code loaded, incurring a load-time and memory usage overhead.
Obviously, there's also duplicated work involved in maintaining the
different adaptions of the `fmt' code.
I think the ideal solution would be to move the R6RS library definitions
upstream, but I don't think that's realistic just yet, as (a) there's no
built-in `include' in R6RS (I think R7RS will fix that), so an `include'
implementation would either have to be shipped, again resulting in code
duplication with other libraries (as `include' is portably implementable
in R6RS), and (b) there's not yet a real, entrenched standard for naming
of R6RS library files (which again might be fixed by R7RS, and could in
the meantime be mitigated by a package manager such as dorodango,
although implementation-specific library<->file name mapping is not yet
implemented).
Even given all that, if some core component of Guile itself (e.g., a VM
code generator) wants to make use of `fmt', there's probably no way
around shipping a copy in core Guile itself.
Just my 0.02€
--
Andreas Rottmann -- <http://rotty.yi.org/>
^ permalink raw reply [flat|nested] 13+ messages in thread
* Re: Fmt Module
2011-03-24 0:45 ` Andreas Rottmann
@ 2011-03-24 21:14 ` Ludovic Courtès
2011-03-26 14:03 ` Andreas Rottmann
0 siblings, 1 reply; 13+ messages in thread
From: Ludovic Courtès @ 2011-03-24 21:14 UTC (permalink / raw)
To: Andreas Rottmann; +Cc: guile-devel
Hello,
Andreas Rottmann <a.rottmann@gmx.at> writes:
> ludo@gnu.org (Ludovic Courtès) writes:
[...]
>> I think it would make sense to include ‘fmt’ in core Guile only if the
>> API is reasonably stable and there are infrequent upstream releases, so
>> we don’t quickly end up shipping an old incompatible version.
>>
> I think `fmt' qualifies these criteria.
OK.
> However, even if I think based on your criteria nothing speaks against
> including fmt in Guile, there is still the argument of code duplication:
> if some external library (e.g., conjure) makes use of wak-fmt and
> another chooses the version included in Guile, a third program/library
> can't make use of both of these without ending up with two copies of the
> `fmt' code loaded, incurring a load-time and memory usage overhead.
> Obviously, there's also duplicated work involved in maintaining the
> different adaptions of the `fmt' code.
I agree.
I think there’s a tension between the interest of Guile, which is to
provide a convenient way to access useful features, and the interests of
implementation-neutral “platforms” like Wak. For instance I find it
important to have SXML, LALR, etc. usable out-of-the-box; it lowers the
barrier to entry.
Besides it’s still unclear (to me) what the future of Wak and similar
projects is. I hope that it will take off, but I haven’t forgotten
Snow, ScmPkg, etc. either.
> I think the ideal solution
I think there’s no ideal solution, not yet. :-)
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 13+ messages in thread
* Re: Fmt Module
2011-03-24 21:14 ` Ludovic Courtès
@ 2011-03-26 14:03 ` Andreas Rottmann
2011-03-27 14:01 ` Ludovic Courtès
0 siblings, 1 reply; 13+ messages in thread
From: Andreas Rottmann @ 2011-03-26 14:03 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: guile-devel
ludo@gnu.org (Ludovic Courtès) writes:
> Hello,
>
> Andreas Rottmann <a.rottmann@gmx.at> writes:
>
>> ludo@gnu.org (Ludovic Courtès) writes:
>
>> However, even if I think based on your criteria nothing speaks against
>> including fmt in Guile, there is still the argument of code duplication:
>> if some external library (e.g., conjure) makes use of wak-fmt and
>> another chooses the version included in Guile, a third program/library
>> can't make use of both of these without ending up with two copies of the
>> `fmt' code loaded, incurring a load-time and memory usage overhead.
>> Obviously, there's also duplicated work involved in maintaining the
>> different adaptions of the `fmt' code.
>
> I agree.
>
> I think there’s a tension between the interest of Guile, which is to
> provide a convenient way to access useful features, and the interests of
> implementation-neutral “platforms” like Wak. For instance I find it
> important to have SXML, LALR, etc. usable out-of-the-box; it lowers the
> barrier to entry.
>
I certainly understand that. Hopefully the CPAN effort for Guile will
bear some fruits and make it very easy to get additional libraries
installed.
> Besides it’s still unclear (to me) what the future of Wak and similar
> projects is. I hope that it will take off, but I haven’t forgotten
> Snow, ScmPkg, etc. either.
>
Well, there's a (IMHO) important difference in that Wak packages are
based on R6RS, which specifies a module system. This way, you don't
really need a package manager to install the code from Wak -- you can
reasonably install by copying or symlinking files.
>> I think the ideal solution
>
> I think there’s no ideal solution, not yet. :-)
>
Indeed, that's why I used the subjunctive and even said that the
(hypothetical) ideal solution is not realistic yet :-p.
Regards, Rotty
--
Andreas Rottmann -- <http://rotty.yi.org/>
^ permalink raw reply [flat|nested] 13+ messages in thread
* Re: Fmt Module
2011-03-26 14:03 ` Andreas Rottmann
@ 2011-03-27 14:01 ` Ludovic Courtès
0 siblings, 0 replies; 13+ messages in thread
From: Ludovic Courtès @ 2011-03-27 14:01 UTC (permalink / raw)
To: Andreas Rottmann; +Cc: guile-devel
Hello,
Andreas Rottmann <a.rottmann@gmx.at> writes:
> ludo@gnu.org (Ludovic Courtès) writes:
[...]
>> Besides it’s still unclear (to me) what the future of Wak and similar
>> projects is. I hope that it will take off, but I haven’t forgotten
>> Snow, ScmPkg, etc. either.
>>
> Well, there's a (IMHO) important difference in that Wak packages are
> based on R6RS, which specifies a module system.
But it doesn’t specify how modules are mapped to files.
And there’s R7RS, which specifies and slightly incompatible module
system, and there’s people who’ll always want to use their
implementation’s native module system, etc.
Let’s hope I’m overly pessimistic. :-)
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 13+ messages in thread
* Re: Fmt Module
2011-03-14 17:16 ` Ludovic Courtès
2011-03-14 17:35 ` Klaus Schilling
2011-03-24 0:45 ` Andreas Rottmann
@ 2011-03-27 11:10 ` Andy Wingo
2011-03-27 15:38 ` Noah Lavine
2 siblings, 1 reply; 13+ messages in thread
From: Andy Wingo @ 2011-03-27 11:10 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: guile-devel
On Mon 14 Mar 2011 18:16, ludo@gnu.org (Ludovic Courtès) writes:
> I think it would make sense to include ‘fmt’ in core Guile only if the
> API is reasonably stable and there are infrequent upstream releases, so
> we don’t quickly end up shipping an old incompatible version.
Agreed, and I don't know if this is the case or not.
I would add on another criteria, that we should avoid adding modules to
Guile unless they are to be used in Guile itself. For everything else,
there is our CPAN that we need to make -- it will provide more freedom
both for module authors/packagers and for users.
Regards,
Andy
--
http://wingolog.org/
^ permalink raw reply [flat|nested] 13+ messages in thread
* Re: Fmt Module
2011-03-27 11:10 ` Andy Wingo
@ 2011-03-27 15:38 ` Noah Lavine
2011-03-27 23:24 ` Andreas Rottmann
0 siblings, 1 reply; 13+ messages in thread
From: Noah Lavine @ 2011-03-27 15:38 UTC (permalink / raw)
To: Andy Wingo; +Cc: Ludovic Courtès, guile-devel
Hello,
>> I think it would make sense to include ‘fmt’ in core Guile only if the
>> API is reasonably stable and there are infrequent upstream releases, so
>> we don’t quickly end up shipping an old incompatible version.
>
> Agreed, and I don't know if this is the case or not.
>
> I would add on another criteria, that we should avoid adding modules to
> Guile unless they are to be used in Guile itself. For everything else,
> there is our CPAN that we need to make -- it will provide more freedom
> both for module authors/packagers and for users.
This makes sense, but I think there is an important distinction to
make that we do not currently make. We should have a clear idea of
what modules are used by Guile, so we can get a "minimal" Guile when
we want it, for instance for embedding into other applications.
However, it would be great if the standard install of Guile included
lots of modules, such as htmlprag, because it is nice to have the
batteries included when you are programming.
Noah
^ permalink raw reply [flat|nested] 13+ messages in thread
* Re: Fmt Module
2011-03-27 15:38 ` Noah Lavine
@ 2011-03-27 23:24 ` Andreas Rottmann
0 siblings, 0 replies; 13+ messages in thread
From: Andreas Rottmann @ 2011-03-27 23:24 UTC (permalink / raw)
To: Noah Lavine; +Cc: Andy Wingo, Ludovic Courtès, guile-devel
Noah Lavine <noah.b.lavine@gmail.com> writes:
> Hello,
>
>>> I think it would make sense to include ‘fmt’ in core Guile only if the
>>> API is reasonably stable and there are infrequent upstream releases, so
>>> we don’t quickly end up shipping an old incompatible version.
>>
>> Agreed, and I don't know if this is the case or not.
>>
>> I would add on another criteria, that we should avoid adding modules to
>> Guile unless they are to be used in Guile itself. For everything else,
>> there is our CPAN that we need to make -- it will provide more freedom
>> both for module authors/packagers and for users.
>
> This makes sense, but I think there is an important distinction to
> make that we do not currently make. We should have a clear idea of
> what modules are used by Guile, so we can get a "minimal" Guile when
> we want it, for instance for embedding into other applications.
>
+1! Racket has acquired a problem with that over the years, and there
are now efforts to rectify it [0].
[0] http://www.mail-archive.com/dev@racket-lang.org/msg02376.html
> However, it would be great if the standard install of Guile included
> lots of modules, such as htmlprag, because it is nice to have the
> batteries included when you are programming.
>
My opinion on that is that if it's really easy to install additional
libraries (which is not yet the case, unfortunatly!), there would be no
need to bundle additional stuff not needed by the core into Guile
releases.
Regards, Rotty
--
Andreas Rottmann -- <http://rotty.yi.org/>
^ 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).