Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-08 05:27:35 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Adding initial version of (chibi show) successor to the fmt combinator formatting library.

Browse source
This commit is contained in:
Alex Shinn 2013-10-08 21:31:20 +09:00
parent 952d665860
commit 3ce042bba1
7 changed files with 1056 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
Makefile
View file

@ -251,7 +251,7 @@ install: all
$(INSTALL) chibi-scheme$(EXE) $(DESTDIR)$(BINDIR)/
$(INSTALL) tools/chibi-ffi $(DESTDIR)$(BINDIR)/
$(INSTALL) tools/chibi-doc $(DESTDIR)$(BINDIR)/
$(MKDIR) $(DESTDIR)$(MODDIR)/chibi/char-set $(DESTDIR)$(MODDIR)/chibi/io $(DESTDIR)$(MODDIR)/chibi/iset $(DESTDIR)$(MODDIR)/chibi/loop $(DESTDIR)$(MODDIR)/chibi/match $(DESTDIR)$(MODDIR)/chibi/monad $(DESTDIR)$(MODDIR)/chibi/net $(DESTDIR)$(MODDIR)/chibi/optimize $(DESTDIR)$(MODDIR)/chibi/parse $(DESTDIR)$(MODDIR)/chibi/term
$(MKDIR) $(DESTDIR)$(MODDIR)/chibi/char-set $(DESTDIR)$(MODDIR)/chibi/io $(DESTDIR)$(MODDIR)/chibi/iset $(DESTDIR)$(MODDIR)/chibi/loop $(DESTDIR)$(MODDIR)/chibi/match $(DESTDIR)$(MODDIR)/chibi/monad $(DESTDIR)$(MODDIR)/chibi/net $(DESTDIR)$(MODDIR)/chibi/optimize $(DESTDIR)$(MODDIR)/chibi/parse $(DESTDIR)$(MODDIR)/chibi/show $(DESTDIR)$(MODDIR)/chibi/term
$(MKDIR) $(DESTDIR)$(MODDIR)/scheme/char
$(MKDIR) $(DESTDIR)$(MODDIR)/scheme/time
$(MKDIR) $(DESTDIR)$(MODDIR)/srfi/1 $(DESTDIR)$(MODDIR)/srfi/18 $(DESTDIR)$(MODDIR)/srfi/27 $(DESTDIR)$(MODDIR)/srfi/33 $(DESTDIR)$(MODDIR)/srfi/39 $(DESTDIR)$(MODDIR)/srfi/69 $(DESTDIR)$(MODDIR)/srfi/95 $(DESTDIR)$(MODDIR)/srfi/99 $(DESTDIR)$(MODDIR)/srfi/99/records
@ -266,6 +266,7 @@ install: all
$(INSTALL) lib/chibi/net/*.sld lib/chibi/net/*.scm $(DESTDIR)$(MODDIR)/chibi/net/
$(INSTALL) lib/chibi/optimize/*.sld lib/chibi/optimize/*.scm $(DESTDIR)$(MODDIR)/chibi/optimize/
$(INSTALL) lib/chibi/parse/*.sld lib/chibi/parse/*.scm $(DESTDIR)$(MODDIR)/chibi/parse/
$(INSTALL) lib/chibi/show/*.sld lib/chibi/show/*.scm $(DESTDIR)$(MODDIR)/chibi/show/
$(INSTALL) lib/chibi/term/*.sld lib/chibi/term/*.scm $(DESTDIR)$(MODDIR)/chibi/term/
$(INSTALL) lib/scheme/*.sld lib/scheme/*.scm $(DESTDIR)$(MODDIR)/scheme/
$(INSTALL) lib/scheme/char/*.sld lib/scheme/char/*.scm $(DESTDIR)$(MODDIR)/scheme/char/
@ -326,6 +327,7 @@ uninstall:
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/net $(DESTDIR)$(BINMODDIR)/chibi/net
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/optimize $(DESTDIR)$(BINMODDIR)/chibi/optimize
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/parse $(DESTDIR)$(BINMODDIR)/chibi/parse
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/show $(DESTDIR)$(BINMODDIR)/chibi/show
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/term $(DESTDIR)$(BINMODDIR)/chibi/term
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi $(DESTDIR)$(BINMODDIR)/chibi
-$(RMDIR) $(DESTDIR)$(MODDIR)/scheme/char $(DESTDIR)$(BINMODDIR)/scheme/char

13
lib/chibi/show.sld Normal file
View file

@ -0,0 +1,13 @@
(define-library (chibi show)
(export
show fn fn-fork with update! each each-in-list call-with-output
displayed written written-shared written-simply numeric nothing
nl fl space-to tab-to
padded padded/left padded/right padded/both
trimmed trimmed/left trimmed/right trimmed/both trimmed/lazy
fitted fitted/left fitted/right fitted/both
joined joined/prefix joined/suffix joined/last joined/dot
upcased downcased)
(import (scheme base) (scheme char) (chibi show base) (scheme write))
(include "show/show.scm"))

175
lib/chibi/show/base.scm Normal file
View file

@ -0,0 +1,175 @@
;; base.scm - base formatting monad
;; Copyright (c) 2013 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
;;> A library of procedures for formatting Scheme objects to text in
;;> various ways, and for easily concatenating, composing and
;;> extending these formatters efficiently without resorting to
;;> capturing and manipulating intermediate strings.
;;> \section{Background}
;;>
;;> There are several approaches to text formatting. Building strings to
;;> \q{display} is not acceptable, since it doesn't scale to very large
;;> output. The simplest realistic idea, and what people resort to in
;;> typical portable Scheme, is to interleave \q{display} and \q{write}
;;> and manual loops, but this is both extremely verbose and doesn't
;;> compose well. A simple concept such as padding space can't be
;;> achieved directly without somehow capturing intermediate output.
;;>
;;> The traditional approach is to use templates - typically strings,
;;> though in theory any object could be used and indeed Emacs' mode-line
;;> format templates allow arbitrary sexps. Templates can use either
;;> escape sequences (as in C's \q{printf} and \urlh{#BIBITEM_2}{CL's}
;;> \q{format}) or pattern matching (as in Visual Basic's \q{Format},
;;> \urlh{#BIBITEM_6}{Perl6's} \q{form}, and SQL date formats). The
;;> primary disadvantage of templates is the relative difficulty (usually
;;> impossibility) of extending them, their opaqueness, and the
;;> unreadability that arises with complex formats. Templates are not
;;> without their advantages, but they are already addressed by other
;;> libraries such as \urlh{#BIBITEM_3}{SRFI-28} and
;;> \urlh{#BIBITEM_4}{SRFI-48}.
;;>
;;> This library takes a combinator approach. Formats are nested chains
;;> of closures, which are called to produce their output as needed.
;;> The primary goal of this library is to have, first and foremost, a
;;> maximally expressive and extensible formatting library. The next
;;> most important goal is scalability - to be able to handle
;;> arbitrarily large output and not build intermediate results except
;;> where necessary. The third goal is brevity and ease of use.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The environment monad with some pre-defined fields for combinator
;; formatting.
(define-environment-monad Show-Env
(sequence: sequence)
(bind: fn)
(bind-fork: fn-fork)
(local: %with)
(local!: update!)
(return: return)
(run: run)
;; These are never used directly, but we must provide the names to
;; preserve hygiene.
(ask: ask %ask)
(tell: tell %tell)
(copy: copy)
(fields:
(port env-port env-port-set!)
(row env-row env-row-set!)
(col env-col env-col-set!)
(width env-width env-width-set!)
(radix env-radix env-radix-set!)
(precision env-precision env-precision-set!)
(pad-char env-pad-char env-pad-char-set!)
(decimal-sep env-decimal-sep env-decimal-sep-set!)
(decimal-align env-decimal-align env-decimal-align-set!)
(string-width env-string-width env-string-width-set!)
(ellipsis env-ellipsis env-ellipsis-set!)
(writer env-writer env-writer-set!)
(output env-output env-output-set!)))
(define-syntax with
(syntax-rules ()
((with params x) (%with params (displayed x)))
((with params . x) (%with params (each . x)))))
;; The base formatting handles outputting raw strings and a simple,
;; configurable handler for formatting objects.
;; Utility - default value of string-width.
(define (substring-length str . o)
(let ((start (if (pair? o) (car o) 0))
(end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str))))
(- end start)))
;; Raw output - displays str to the formatter output port and updates
;; row and col.
(define (output-default str)
(fn (port row col string-width)
(display str port)
(let ((nl-index (string-find-right str #\newline)))
(if (> nl-index 0)
(update! (row (+ row (string-count str #\newline)))
(col (string-width str nl-index)))
(update! (col (+ col (string-width str))))))))
;; Raw output. All primitive output should go through this operation.
;; Overridable, defaulting to output-default.
(define (output str)
(fn (output) ((or output output-default) str)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;> The primary interface. Analogous to CL's \scheme{format}, the first
;;> argument is either an output port or a boolean, with \scheme{#t}
;;> indicating \scheme{current-output-port} and \scheme{#f} indicating a
;;> string port. The remaining arguments are formatters, combined as with
;;> \scheme{each}, run with output to the given destination. If \var{out}
;;> is \scheme{#f} then the accumulated output is returned, otherwise
;;> the result is unspecified.
(define (show out . args)
(let ((proc (each-in-list args)))
(cond
((output-port? out)
(show-run out proc))
((eq? #t out)
(show-run (current-output-port) proc))
((eq? #f out)
(let ((out (open-output-string)))
(show-run out proc)
(get-output-string out)))
(else
(error "unknown output to show" out)))))
;; Run with an output port with initial default values.
(define (show-run out proc)
(run (sequence (update! (port out)
(col 0)
(row 0)
(width 78)
(radix 10)
(pad-char #\space)
(output output-default)
(string-width substring-length))
proc)))
;;> Captures the output of \var{producer} and formats the result with
;;> \var{consumer}.
(define (call-with-output producer consumer)
(let ((out (open-output-string)))
(fn-fork (with ((port out)) producer)
(fn () (consumer (get-output-string out))))))
;;> The noop formatter. Generates no output and leaves the state
;;> unmodified.
(define nothing (fn () (update!)))
;;> Formats a displayed version of x - if a string or char, outputs the
;;> raw characters (as with `display'), if x is already a formatter
;;> defers to that, otherwise outputs a written version of x.
(define (displayed x)
(cond
((procedure? x) x)
((string? x) (output x))
((char? x) (output (string x)))
(else (written x))))
;;> Formats a written version of x, as with `write'. The formatting
;;> can be updated with the \scheme{'writer} field.
(define (written x)
(fn (writer) ((or writer written-default) x)))
;;> Takes a single list of formatters, combined in sequence with
;;> \scheme{each}.
(define (each-in-list args)
(if (pair? args)
(sequence (displayed (car args)) (each-in-list (cdr args)))
nothing))
;;> Combines each of the formatters in a sequence using
;;> \scheme{displayed}, so that strings and chars will be output
;;> directly and other objects will be \scheme{written}.
(define (each . args)
(each-in-list args))

10
lib/chibi/show/base.sld Normal file
View file

@ -0,0 +1,10 @@
(define-library (chibi show base)
(export
show fn fn-fork with update! each each-in-list call-with-output
displayed written written-shared written-simply numeric nothing
output-default)
(import (scheme base) (scheme write) (scheme complex) (scheme inexact)
(srfi 1) (srfi 69) (chibi string) (chibi monad environment))
(include "base.scm")
(include "write.scm"))

195
lib/chibi/show/show.scm Normal file
View file

@ -0,0 +1,195 @@
;; show.scm -- additional combinator formatters
;; Copyright (c) 2013 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Spacing
;;> Output a single newline.
(define nl (displayed "\n"))
;;> "Fresh line" - output a newline iff we're not at the start of a
;;> fresh line.
(define fl
(fn (col) (if (zero? col) nothing nl)))
;;> Move to a given tab-stop (using spaces, not tabs).
(define (tab-to . o)
(fn (col pad-char)
(let* ((tab-width (if (pair? o) (car o) 8))
(rem (modulo col tab-width)))
(if (positive? rem)
(displayed (make-string (- tab-width rem) pad-char))
nothing))))
;;> Move to an explicit column.
(define (space-to where)
(fn (col pad-char)
(displayed (make-string (max 0 (- where col)) pad-char))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; String transformations
(define (with-string-transformer proc . ls)
(fn (output)
(let ((output* (lambda (str) (fn () (output (proc str))))))
(with ((output output*)) (each-in-list ls)))))
(define (upcased . ls) (apply with-string-transformer string-upcase ls))
(define (downcased . ls) (apply with-string-transformer string-downcase ls))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Padding and trimming
(define (padded/both width . ls)
(call-with-output
(each-in-list ls)
(lambda (str)
(fn (string-width pad-char)
(let ((diff (- width (string-width str))))
(if (positive? diff)
(let* ((diff/2 (quotient diff 2))
(left (make-string diff/2 pad-char))
(right (if (even? diff)
left
(make-string (+ 1 diff/2) pad-char))))
(each right str left))
(displayed str)))))))
(define (padded width . ls)
(fn ((col1 col))
(each (each-in-list ls)
(fn ((col2 col) pad-char)
(displayed (make-string (max 0 (- width (- col2 col1)))
pad-char))))))
(define padded/right padded)
(define (padded/left width . ls)
(call-with-output
(each-in-list ls)
(lambda (str)
(fn (string-width pad-char)
(let ((diff (- width (string-width str))))
(each (make-string diff pad-char) str))))))
;; General buffered trim - capture the output apply a trimmer.
(define (trimmed/buffered width producer proc)
(call-with-output
producer
(lambda (str)
(fn (string-width)
(let* ((str-width (string-width str))
(diff (- str-width width)))
(displayed (if (positive? diff)
(proc str str-width diff)
str)))))))
(define (trimmed width . ls)
(trimmed/buffered
width
(each-in-list ls)
(lambda (str str-width diff)
(fn (ellipsis string-width col)
(let* ((ell (if (char? ellipsis) (string ellipsis) (or ellipsis "")))
(ell-len (string-width ell))
(diff (- (+ str-width ell-len) width)))
(each (if (negative? diff)
nothing
(substring str 0 (- width ell-len)))
ell))))))
(define trimmed/right trimmed)
(define (trimmed/left width . ls)
(trimmed/buffered
width
(each-in-list ls)
(lambda (str str-width diff)
(fn (ellipsis string-width)
(let* ((ell (if (char? ellipsis) (string ellipsis) (or ellipsis "")))
(ell-len (string-width ell))
(diff (- (+ str-width ell-len) width)))
(each ell
(if (negative? diff)
nothing
(substring str diff))))))))
(define (trimmed/both width . ls)
(trimmed/buffered
width
(each-in-list ls)
(lambda (str str-width diff)
(fn (ellipsis string-width)
(let* ((ell (if (char? ellipsis) (string ellipsis) (or ellipsis "")))
(ell-len (string-width ell))
(diff (- (+ str-width ell-len ell-len) width))
(left (quotient diff 2))
(right (- (string-width str) (quotient (+ diff 1) 2))))
(if (negative? diff)
ell
(each ell (substring str left right) ell)))))))
(define (trimmed/lazy width . ls)
(fn (orig-output string-width)
(call-with-current-continuation
(lambda (return)
(let ((chars-written 0)
(output (or orig-output output-default)))
(define (output* str)
(let ((len (string-width str)))
(set! chars-written (+ chars-written len))
(if (> chars-written width)
(let* ((end (max 0 (- len (- chars-written width))))
(s (substring str 0 end)))
(each (output s)
(update! (output orig-output))
(fn () (return nothing))))
(output str))))
(with ((output output*))
(each-in-list ls)))))))
(define (fitted width . ls)
(padded width (trimmed width (each-in-list ls))))
(define fitted/right fitted)
(define (fitted/left width . ls)
(padded/left width (trimmed/left width (each-in-list ls))))
(define (fitted/both width . ls)
(padded/both width (trimmed/both width (each-in-list ls))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Joining and interspersing
(define (joined/general elt-f last-f dot-f init-ls sep)
(fn ()
(let lp ((ls init-ls))
(cond
((pair? ls)
(each (if (eq? ls init-ls) nothing sep)
((if (and last-f (null? (cdr ls))) last-f elt-f) (car ls))
(lp (cdr ls))))
((and dot-f (not (null? ls)))
(each (if (eq? ls init-ls) nothing sep) (dot-f ls)))
(else
nothing)))))
(define (joined elt-f ls . o)
(joined/general elt-f #f #f ls (if (pair? o) (car o) "")))
(define (joined/prefix elt-f ls . o)
(if (null? ls)
nothing
(let ((sep (if (pair? o) (car o) "")))
(each sep (joined elt-f ls sep)))))
(define (joined/suffix elt-f ls . o)
(if (null? ls)
nothing
(let ((sep (if (pair? o) (car o) "")))
(each (joined elt-f ls sep) sep))))
(define (joined/last elt-f last-f ls . o)
(joined/general elt-f last-f #f ls (if (pair? o) (car o) "")))
(define (joined/dot elt-f dot-f ls . o)
(joined/general elt-f #f dot-f ls (if (pair? o) (car o) "")))

374
lib/chibi/show/write.scm Normal file
View file

@ -0,0 +1,374 @@
;; write.scm - written formatting, the default displayed for non-string/chars
;; Copyright (c) 2013 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; string utils
(define (write-to-string x)
(let ((out (open-output-string)))
(write x out)
(get-output-string out)))
(define (string-replace-all str ch1 ch2)
(let ((out (open-output-string)))
(string-for-each
(lambda (ch) (write-char (if (eqv? ch ch1) ch2 ch) out))
str)
(get-output-string out)))
(define (string-intersperse-right str sep rule)
(let lp ((i (string-length str))
(rule rule)
(res '()))
(let* ((offset (if (pair? rule) (car rule) rule))
(i2 (if offset (- i offset) 0)))
(if (<= i2 0)
(apply string-append (cons (substring str 0 i) res))
(lp i2
(if (pair? rule) (cdr rule) rule)
(cons sep (cons (substring str i2 i) res)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; numeric formatting
(define (char-mirror c)
(case c ((#\() #\)) ((#\[) #\]) ((#\{) #\}) ((#\<) #\>) (else c)))
(define (integer-log a base)
(if (zero? a)
0
(exact (ceiling (/ (log (+ a 1)) (log base))))))
;; The original fmt algorithm was based on "Printing Floating-Point
;; Numbers Quickly and Accurately" by Burger and Dybvig
;; (FP-Printing-PLDI96.pdf). It had grown unwieldy with formatting
;; special cases, so the below is a simplification which tries to rely
;; on number->string for common cases.
(define (numeric n)
(fn (radix precision decimal-sep decimal-align comma-rule comma-sep sign-rule)
(let ((dec-sep (or decimal-sep (if (eqv? comma-sep #\.) #\, #\.))))
;; General formatting utilities.
(define (get-scale q)
(expt radix (- (integer-log q radix) 1)))
(define (char-digit d)
(cond ((char? d) d)
((< d 10) (integer->char (+ d (char->integer #\0))))
(else (integer->char (+ (- d 10) (char->integer #\A))))))
(define (digit-value ch)
(let ((res (- (char->integer ch) (char->integer #\0))))
(if (<= 0 res 9)
res
ch)))
(define (round-up ls)
(let lp ((ls ls) (res '()))
(cond
((null? ls)
(cons 1 res))
((not (number? (car ls)))
(lp (cdr ls) (cons (car ls) res)))
((= (car ls) (- radix 1))
(lp (cdr ls) (cons 0 res)))
(else
(append (reverse res) (cons (+ 1 (car ls)) (cdr ls)))))))
(define (maybe-round n d ls)
(let* ((q (quotient n d))
(digit (* 2 (if (>= q radix) (quotient q (get-scale q)) q))))
(if (or (> digit radix)
(and (= digit radix)
(let ((prev (find integer? ls)))
(and prev (odd? prev)))))
(round-up ls)
ls)))
(define (maybe-trim-zeros i res)
(if (and (not precision) (positive? i))
(let lp ((res res))
(cond
((and (pair? res) (eqv? 0 (car res))) (lp (cdr res)))
((and (pair? res) (eqv? dec-sep (car res))) (cdr res))
(else res)))
res))
;; General slow loop to generate digits one at a time, for
;; non-standard radixes or writing rationals with a fixed
;; precision.
(define (gen-general n)
(let* ((p (exact n))
(n (numerator p))
(d (denominator p)))
(let lp ((n n)
(i (- (integer-log p radix)))
(res '()))
(cond
;; Use a fixed precision if specified, otherwise generate
;; 15 decimals.
((if precision (< i precision) (< i 16))
(let ((res (if (zero? i)
(cons dec-sep (if (null? res) (cons 0 res) res))
res))
(q (quotient n d)))
(cond
((>= q radix)
(let* ((scale (get-scale q))
(digit (quotient q scale))
(n2 (- n (* d digit scale))))
(lp n2 (+ i 1) (cons digit res))))
(else
(lp (* (remainder n d) radix)
(+ i 1)
(cons q res))))))
(else
(list->string
(map char-digit
(reverse (maybe-round n d (maybe-trim-zeros i res))))))))))
;; Generate a fixed precision decimal result by post-editing the
;; result of string->number.
(define (gen-fixed n)
(cond
((and (eqv? radix 10) (or (integer? n) (inexact? n)))
(let* ((s (number->string n))
(len (string-length s))
(dec (string-find s #\.))
(digits (- len dec)))
(cond
((< (string-find s #\e) len)
(gen-general n))
((= dec len)
(string-append s "." (make-string precision #\0)))
((<= digits precision)
(string-append s (make-string (- precision digits -1) #\0)))
(else
(let* ((last (- len (- digits precision 1)))
(res (substring s 0 last)))
(if (and
(< last len)
(let ((next (digit-value (string-ref s last))))
(or (> next 5)
(and (= next 5) (> last 0)
(odd? (digit-value
(string-ref s (- last 1))))))))
(list->string
(reverse
(map char-digit
(round-up
(reverse (map digit-value (string->list res)))))))
res))))))
(else
(gen-general n))))
;; Generate any unsigned real number.
(define (gen-positive-real n)
(cond
(precision
(gen-fixed n))
((and (exact? n) (not (integer? n)))
(string-append (number->string (numerator n) radix)
"/"
(number->string (denominator n) radix)))
((memv radix (if (exact? n) '(2 8 10 16) '(10)))
(number->string n))
(else
(gen-general n))))
;; Insert commas according to the current comma-rule.
(define (insert-commas str)
(let* ((dec-pos (string-find str dec-sep))
(left (substring str 0 dec-pos))
(right (substring str dec-pos))
(sep (cond ((char? comma-sep) (string comma-sep))
((string? comma-sep) comma-sep)
((eqv? #\, dec-sep) ".")
(else ","))))
(string-append
(string-intersperse-right left sep comma-rule)
right)))
;; Post-process a positive real number with decimal char fixup
;; and commas as needed.
(define (wrap-comma n)
(let* ((s0 (gen-positive-real n))
(s1 (if (and (char? dec-sep)
(not (eqv? #\. dec-sep)))
(string-replace-all s0 #\. dec-sep)
s0)))
(if comma-rule (insert-commas s1) s1)))
;; Wrap the sign of a real number, forcing a + prefix or using
;; parentheses (n) for negatives according to sign-rule.
(define (wrap-sign n sign-rule)
(cond
((negative? n)
(if (char? sign-rule)
(string-append (string sign-rule)
(wrap-comma (abs n))
(string (char-mirror sign-rule)))
(string-append "-" (wrap-comma (abs n)))))
((eq? #t sign-rule)
(string-append "+" (wrap-comma n)))
(else
(wrap-comma n))))
;; Format a single real number with padding as necessary.
(define (format n sign-rule)
(let ((s (wrap-sign n sign-rule)))
(let* ((dec-pos (if decimal-align (string-find s dec-sep) 0))
(diff (- (or decimal-align 0) dec-pos 1)))
(if (positive? diff)
(string-append (make-string diff #\space) s)
s))))
;; Write any number.
(define (write-complex n)
(cond
((and radix (not (and (integer? radix) (<= 2 radix 36))))
(error "invalid radix for numeric formatting" radix))
((zero? (imag-part n))
(displayed (format (real-part n) sign-rule)))
(else
(each (format (real-part n) sign-rule)
(format (imag-part n) #t)
"i"))))
(write-complex n))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; shared structure utilities
(define (extract-shared-objects x cyclic-only?)
(let ((seen (make-hash-table eq?)))
;; find shared references
(let find ((x x))
(cond ;; only interested in pairs and vectors (and records later)
((or (pair? x) (vector? x))
;; increment the count
(hash-table-update!/default seen x (lambda (n) (+ n 1)) 0)
;; walk if this is the first time
(cond
((> (hash-table-ref seen x) 1))
((pair? x)
(find (car x))
(find (cdr x)))
((vector? x)
(do ((i 0 (+ i 1)))
((= i (vector-length x)))
(find (vector-ref x i)))))
;; delete if this shouldn't count as a shared reference
(if (and cyclic-only? (<= (hash-table-ref/default seen x 0) 1))
(hash-table-delete! seen x)))))
;; extract shared references
(let ((res (make-hash-table eq?))
(count 0))
(hash-table-walk
seen
(lambda (k v)
(cond
((> v 1)
(hash-table-set! res k (cons count #f))
(set! count (+ count 1))))))
res)))
(define (maybe-gen-shared-ref cell shares)
(cond
((pair? cell)
(set-car! cell (cdr shares))
(set-cdr! cell #t)
(set-cdr! shares (+ (cdr shares) 1))
(each "#" (number->string (car cell)) "="))
(else nothing)))
(define (call-with-shared-ref obj shares proc)
(let ((cell (hash-table-ref/default (car shares) obj #f)))
(if (and (pair? cell) (cdr cell))
(each "#" (number->string (car cell)) "#")
(each (maybe-gen-shared-ref cell shares) proc))))
(define (call-with-shared-ref/cdr obj shares proc)
(let ((cell (hash-table-ref/default (car shares) obj #f)))
(cond
((and (pair? cell) (cdr cell))
(each ". #" (number->string (car cell)) "#"))
((pair? cell)
(each ". " (maybe-gen-shared-ref cell shares) "(" proc ")"))
(else
proc))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; written
(define (write-with-shares obj shares)
(fn (radix precision)
(let ((write-number
;; Shortcut for numeric values. Try to rely on
;; number->string for standard radixes and no precision,
;; otherwise fall back on numeric but resetting to a usable
;; radix.
(cond
((and (not precision)
(assv radix '((16 . "#x") (10 . "") (8 . "#o") (2 . "#b"))))
=> (lambda (cell)
(lambda (n)
(if (or (exact? n) (eqv? radix 10))
(each (cdr cell) (number->string n (car cell)))
(with ((radix 10)) (numeric n))))))
(else (lambda (n) (with ((radix 10)) (numeric n)))))))
;; `wr' is the recursive writer closing over the shares.
(let wr ((obj obj))
(call-with-shared-ref
obj shares
(fn ()
(cond
((pair? obj)
(each "("
(fn ()
(let lp ((ls obj))
(let ((rest (cdr ls)))
(each (wr (car ls))
(cond
((null? rest)
nothing)
((pair? rest)
(each
" "
(call-with-shared-ref/cdr
rest shares
(fn () (lp rest)))))
(else
(each " . " (wr rest))))))))
")"))
((vector? obj)
(let ((len (vector-length obj)))
(if (zero? len)
(displayed "#()")
(each "#("
(wr (vector-ref obj 0))
(fn ()
(let lp ((i 1))
(if (>= i len)
nothing
(each " " (wr (vector-ref obj i))
(fn () (lp (+ i 1)))))))
")"))))
((number? obj)
(write-number obj))
(else
(displayed (write-to-string obj))))))))))
;; The default formatter for `written', overriden with the `writer'
;; variable. Intended to be equivalent to `write', using datum labels
;; for shared notation iff there are cycles in the object.
(define (written-default obj)
(fn ()
(write-with-shares obj (cons (extract-shared-objects obj #t) 0))))
;; Writes the object showing the full shared structure.
(define (written-shared obj)
(fn ()
(write-with-shares obj (cons (extract-shared-objects obj #f) 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 and re-use the writing
;; code.
(define (written-simply obj)
(fn ()
(write-with-shares obj (cons (make-hash-table eq?) 0))))
;; Local variables:
;; eval: (put 'fn 'scheme-indent-function 1)
;; End:

286
tests/show-tests.scm Normal file
View file

@ -0,0 +1,286 @@
(import (scheme base) (chibi show) (chibi test))
(test-begin "show")
;; basic data types
(test "hi" (show #f "hi"))
(test "\"hi\"" (show #f (written "hi")))
(test "\"hi \\\"bob\\\"\"" (show #f (written "hi \"bob\"")))
(test "\"hello\\nworld\"" (show #f (written "hello\nworld")))
(test "#(1 2 3)" (show #f (written '#(1 2 3))))
(test "(1 2 3)" (show #f (written '(1 2 3))))
(test "(1 2 . 3)" (show #f (written '(1 2 . 3))))
(test "ABC" (show #f (upcased "abc")))
(test "abc" (show #f (downcased "ABC")))
(test "abc def" (show #f "abc" (tab-to) "def"))
(test "abc def" (show #f "abc" (tab-to 5) "def"))
(test "abcdef" (show #f "abc" (tab-to 3) "def"))
;; numbers
(test "-1" (show #f -1))
(test "0" (show #f 0))
(test "1" (show #f 1))
(test "10" (show #f 10))
(test "100" (show #f 100))
(test "-1" (show #f (numeric -1)))
(test "0" (show #f (numeric 0)))
(test "1" (show #f (numeric 1)))
(test "10" (show #f (numeric 10)))
(test "100" (show #f (numeric 100)))
(test "57005" (show #f #xDEAD))
(test "#xDEAD" (show #f (with ((radix 16)) #xDEAD)))
(test "#xDEAD1234" (show #f (with ((radix 16)) #xDEAD) 1234))
(test "DE.AD"
(show #f (with ((radix 16) (precision 2)) (numeric (/ #xDEAD #x100)))))
(test "D.EAD"
(show #f (with ((radix 16) (precision 3)) (numeric (/ #xDEAD #x1000)))))
(test "0.DEAD"
(show #f (with ((radix 16) (precision 4)) (numeric (/ #xDEAD #x10000)))))
(test "1G"
(show #f (with ((radix 17)) (numeric 33))))
(test "3.14159" (show #f 3.14159))
(test "3.14" (show #f (with ((precision 2)) 3.14159)))
(test "3.14" (show #f (with ((precision 2)) 3.14)))
(test "3.00" (show #f (with ((precision 2)) 3.)))
(test "1.10" (show #f (with ((precision 2)) 1.099)))
(test "0.00" (show #f (with ((precision 2)) 1e-17)))
(test "0.0000000010" (show #f (with ((precision 10)) 1e-9)))
(test "0.0000000000" (show #f (with ((precision 10)) 1e-17)))
(test "0.000004" (show #f (with ((precision 6)) 0.000004)))
(test "0.0000040" (show #f (with ((precision 7)) 0.000004)))
(test "0.00000400" (show #f (with ((precision 8)) 0.000004)))
(test " 3.14159" (show #f (with ((decimal-align 5)) (numeric 3.14159))))
(test " 31.4159" (show #f (with ((decimal-align 5)) (numeric 31.4159))))
(test " 314.159" (show #f (with ((decimal-align 5)) (numeric 314.159))))
(test "3141.59" (show #f (with ((decimal-align 5)) (numeric 3141.59))))
(test "31415.9" (show #f (with ((decimal-align 5)) (numeric 31415.9))))
(test " -3.14159" (show #f (with ((decimal-align 5)) (numeric -3.14159))))
(test " -31.4159" (show #f (with ((decimal-align 5)) (numeric -31.4159))))
(test "-314.159" (show #f (with ((decimal-align 5)) (numeric -314.159))))
(test "-3141.59" (show #f (with ((decimal-align 5)) (numeric -3141.59))))
(test "-31415.9" (show #f (with ((decimal-align 5)) (numeric -31415.9))))
(cond
((exact? (/ 1 3)) ;; exact rationals
(test "333.333333333333333333333333333333"
(show #f (with ((precision 30)) (numeric 1000/3))))
(test "33.333333333333333333333333333333"
(show #f (with ((precision 30)) (numeric 100/3))))
(test "3.333333333333333333333333333333"
(show #f (with ((precision 30)) (numeric 10/3))))
(test "0.333333333333333333333333333333"
(show #f (with ((precision 30)) (numeric 1/3))))
(test "0.033333333333333333333333333333"
(show #f (with ((precision 30)) (numeric 1/30))))
(test "0.003333333333333333333333333333"
(show #f (with ((precision 30)) (numeric 1/300))))
(test "0.000333333333333333333333333333"
(show #f (with ((precision 30)) (numeric 1/3000))))
(test "0.666666666666666666666666666667"
(show #f (with ((precision 30)) (numeric 2/3))))
(test "0.090909090909090909090909090909"
(show #f (with ((precision 30)) (numeric 1/11))))
(test "1.428571428571428571428571428571"
(show #f (with ((precision 30)) (numeric 10/7))))
(test "0.123456789012345678901234567890"
(show #f (with ((precision 30))
(numeric (/ 123456789012345678901234567890
1000000000000000000000000000000)))))
(test " 333.333333333333333333333333333333"
(show #f (with ((precision 30) (decimal-align 5)) (numeric 1000/3))))
(test " 33.333333333333333333333333333333"
(show #f (with ((precision 30) (decimal-align 5)) (numeric 100/3))))
(test " 3.333333333333333333333333333333"
(show #f (with ((precision 30) (decimal-align 5)) (numeric 10/3))))
(test " 0.333333333333333333333333333333"
(show #f (with ((precision 30) (decimal-align 5)) (numeric 1/3))))
))
(test "11.75" (show #f (with ((precision 2)) (/ 47 4))))
(test "-11.75" (show #f (with ((precision 2)) (/ -47 4))))
(test "(#x11 #x22 #x33)" (show #f (with ((radix 16)) '(#x11 #x22 #x33))))
(test "299792458" (show #f (with ((comma-rule 3)) 299792458)))
(test "299,792,458" (show #f (with ((comma-rule 3)) (numeric 299792458))))
(test "-29,97,92,458"
(show #f (with ((comma-rule '(3 . 2))) (numeric -299792458))))
(test "299.792.458"
(show #f (with ((comma-rule 3) (comma-sep #\.)) (numeric 299792458))))
(test "299.792.458,0"
(show #f (with ((comma-rule 3) (decimal-sep #\,)) (numeric 299792458.0))))
(test "100,000" (show #f (with ((comma-rule 3)) (numeric 100000))))
(test "100,000.0"
(show #f (with ((comma-rule 3) (precision 1)) (numeric 100000))))
(test "100,000.00"
(show #f (with ((comma-rule 3) (precision 2)) (numeric 100000))))
(cond-expand
(complex
(test "1+2i" (show #f (string->number "1+2i")))
(test "1.00+2.00i"
(show #f (with ((precision 2)) (string->number "1+2i"))))
(test "3.14+2.00i"
(show #f (with ((precision 2)) (string->number "3.14159+2i"))))))
;; padding/trimming
(test "abc " (show #f (padded 5 "abc")))
(test " abc" (show #f (padded/left 5 "abc")))
(test " abc " (show #f (padded/both 5 "abc")))
(test "abcde" (show #f (padded 5 "abcde")))
(test "abcdef" (show #f (padded 5 "abcdef")))
(test "abc" (show #f (trimmed 3 "abcde")))
(test "abc" (show #f (trimmed 3 "abcd")))
(test "abc" (show #f (trimmed 3 "abc")))
(test "ab" (show #f (trimmed 3 "ab")))
(test "a" (show #f (trimmed 3 "a")))
(test "cde" (show #f (trimmed/left 3 "abcde")))
(test "bcd" (show #f (trimmed/both 3 "abcde")))
(test "bcdef" (show #f (trimmed/both 5 "abcdefgh")))
(test "abc" (show #f (trimmed/lazy 3 "abcde")))
(test "abc" (show #f (trimmed/lazy 3 "abc\nde")))
(test "prefix: abc" (show #f "prefix: " (trimmed 3 "abcde")))
(test "prefix: cde" (show #f "prefix: " (trimmed/left 3 "abcde")))
(test "prefix: bcd" (show #f "prefix: " (trimmed/both 3 "abcde")))
(test "prefix: abc" (show #f "prefix: " (trimmed/lazy 3 "abcde")))
(test "prefix: abc" (show #f "prefix: " (trimmed/lazy 3 "abc\nde")))
(test "abc :suffix" (show #f (trimmed 3 "abcde") " :suffix"))
(test "cde :suffix" (show #f (trimmed/left 3 "abcde") " :suffix"))
(test "bcd :suffix" (show #f (trimmed/both 3 "abcde") " :suffix"))
(test "abc :suffix" (show #f (trimmed/lazy 3 "abcde") " :suffix"))
(test "abc :suffix" (show #f (trimmed/lazy 3 "abc\nde") " :suffix"))
(test "abcde"
(show #f (with ((ellipsis "...")) (trimmed 5 "abcde"))))
(test "ab..."
(show #f (with ((ellipsis "...")) (trimmed 5 "abcdef"))))
(test "abc..."
(show #f (with ((ellipsis "...")) (trimmed 6 "abcdefg"))))
(test "abcde"
(show #f (with ((ellipsis "...")) (trimmed/left 5 "abcde"))))
(test "...ef"
(show #f (with ((ellipsis "...")) (trimmed/left 5 "abcdef"))))
(test "...efg"
(show #f (with ((ellipsis "...")) (trimmed/left 6 "abcdefg"))))
(test "abcdefg"
(show #f (with ((ellipsis "...")) (trimmed/both 7 "abcdefg"))))
(test "...d..."
(show #f (with ((ellipsis "...")) (trimmed/both 7 "abcdefgh"))))
(test "...e..."
(show #f (with ((ellipsis "...")) (trimmed/both 7 "abcdefghi"))))
(test "abc " (show #f (fitted 5 "abc")))
(test " abc" (show #f (fitted/left 5 "abc")))
(test " abc " (show #f (fitted/both 5 "abc")))
(test "abcde" (show #f (fitted 5 "abcde")))
(test "abcde" (show #f (fitted/left 5 "abcde")))
(test "abcde" (show #f (fitted/both 5 "abcde")))
(test "abcde" (show #f (fitted 5 "abcdefgh")))
(test "defgh" (show #f (fitted/left 5 "abcdefgh")))
(test "bcdef" (show #f (fitted/both 5 "abcdefgh")))
(test "prefix: abc :suffix"
(show #f "prefix: " (fitted 5 "abc") " :suffix"))
(test "prefix: abc :suffix"
(show #f "prefix: " (fitted/left 5 "abc") " :suffix"))
(test "prefix: abc :suffix"
(show #f "prefix: " (fitted/both 5 "abc") " :suffix"))
(test "prefix: abcde :suffix"
(show #f "prefix: " (fitted 5 "abcde") " :suffix"))
(test "prefix: abcde :suffix"
(show #f "prefix: " (fitted/left 5 "abcde") " :suffix"))
(test "prefix: abcde :suffix"
(show #f "prefix: " (fitted/both 5 "abcde") " :suffix"))
(test "prefix: abcde :suffix"
(show #f "prefix: " (fitted 5 "abcdefgh") " :suffix"))
(test "prefix: defgh :suffix"
(show #f "prefix: " (fitted/left 5 "abcdefgh") " :suffix"))
(test "prefix: bcdef :suffix"
(show #f "prefix: " (fitted/both 5 "abcdefgh") " :suffix"))
;; joining
(test "1 2 3" (show #f (joined each '(1 2 3) " ")))
(test ":abc:123"
(show #f (joined/prefix
(lambda (x) (trimmed 3 x))
'("abcdef" "123456")
":")))
(test "abc\n123\n"
(show #f (joined/suffix
(lambda (x) (trimmed 3 x))
'("abcdef" "123456")
nl)))
(test "lions, tigers, and bears"
(show #f (joined/last
each
(lambda (x) (each "and " x))
'(lions tigers bears)
", ")))
(test "lions, tigers, or bears"
(show #f (joined/dot
each
(lambda (x) (each "or " x))
'(lions tigers . bears)
", ")))
;; shared structures
(test "#0=(1 . #0#)"
(show #f (written (let ((ones (list 1))) (set-cdr! ones ones) ones))))
(test "(0 . #0=(1 . #0#))"
(show #f (written (let ((ones (list 1)))
(set-cdr! ones ones)
(cons 0 ones)))))
(test "(sym . #0=(sym . #0#))"
(show #f (written (let ((syms (list 'sym)))
(set-cdr! syms syms)
(cons 'sym syms)))))
(test "(#0=(1 . #0#) #1=(2 . #1#))"
(show #f (written (let ((ones (list 1))
(twos (list 2)))
(set-cdr! ones ones)
(set-cdr! twos twos)
(list ones twos)))))
(test "(#0=(1 . #0#) #0#)"
(show #f (written (let ((ones (list 1)))
(set-cdr! ones ones)
(list ones ones)))))
(test "((1) (1))"
(show #f (written (let ((ones (list 1)))
(list ones ones)))))
(test "(#0=(1) #0#)"
(show #f (written-shared (let ((ones (list 1)))
(list ones ones)))))
;; cycles without shared detection
(test "(1 1 1 1 1"
(show #f (trimmed/lazy
10
(written-simply
(let ((ones (list 1))) (set-cdr! ones ones) ones)))))
(test "(1 1 1 1 1 "
(show #f (trimmed/lazy
11
(written-simply
(let ((ones (list 1))) (set-cdr! ones ones) ones)))))
(test-end)