mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-08 05:27:35 +02:00
Adding initial version of (chibi show) successor to the fmt combinator formatting library.
This commit is contained in:
parent
952d665860
commit
3ce042bba1
7 changed files with 1056 additions and 1 deletions
4
Makefile
4
Makefile
|
@ -251,7 +251,7 @@ install: all
|
||||||
$(INSTALL) chibi-scheme$(EXE) $(DESTDIR)$(BINDIR)/
|
$(INSTALL) chibi-scheme$(EXE) $(DESTDIR)$(BINDIR)/
|
||||||
$(INSTALL) tools/chibi-ffi $(DESTDIR)$(BINDIR)/
|
$(INSTALL) tools/chibi-ffi $(DESTDIR)$(BINDIR)/
|
||||||
$(INSTALL) tools/chibi-doc $(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/char
|
||||||
$(MKDIR) $(DESTDIR)$(MODDIR)/scheme/time
|
$(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
|
$(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/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/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/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/chibi/term/*.sld lib/chibi/term/*.scm $(DESTDIR)$(MODDIR)/chibi/term/
|
||||||
$(INSTALL) lib/scheme/*.sld lib/scheme/*.scm $(DESTDIR)$(MODDIR)/scheme/
|
$(INSTALL) lib/scheme/*.sld lib/scheme/*.scm $(DESTDIR)$(MODDIR)/scheme/
|
||||||
$(INSTALL) lib/scheme/char/*.sld lib/scheme/char/*.scm $(DESTDIR)$(MODDIR)/scheme/char/
|
$(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/net $(DESTDIR)$(BINMODDIR)/chibi/net
|
||||||
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/optimize $(DESTDIR)$(BINMODDIR)/chibi/optimize
|
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/optimize $(DESTDIR)$(BINMODDIR)/chibi/optimize
|
||||||
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi/parse $(DESTDIR)$(BINMODDIR)/chibi/parse
|
-$(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/term $(DESTDIR)$(BINMODDIR)/chibi/term
|
||||||
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi $(DESTDIR)$(BINMODDIR)/chibi
|
-$(RMDIR) $(DESTDIR)$(MODDIR)/chibi $(DESTDIR)$(BINMODDIR)/chibi
|
||||||
-$(RMDIR) $(DESTDIR)$(MODDIR)/scheme/char $(DESTDIR)$(BINMODDIR)/scheme/char
|
-$(RMDIR) $(DESTDIR)$(MODDIR)/scheme/char $(DESTDIR)$(BINMODDIR)/scheme/char
|
||||||
|
|
13
lib/chibi/show.sld
Normal file
13
lib/chibi/show.sld
Normal 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
175
lib/chibi/show/base.scm
Normal 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
10
lib/chibi/show/base.sld
Normal 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
195
lib/chibi/show/show.scm
Normal 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
374
lib/chibi/show/write.scm
Normal 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
286
tests/show-tests.scm
Normal 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)
|
Loading…
Add table
Reference in a new issue