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.
For Gauche run
For MzScheme you can download and install the latest
http://synthcode.com/scheme/fmt/fmt.plt
To build the
For Scheme48 the package descriptions are in
For other implementations you'll need to load SRFI's 1, 6, 13, 33
(sample provided) and 69 (also provided), and then load the following
files:
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
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.
where
Each
would return the string
A
These parameters may seem unwieldy, but they can also take their
defaults from state variables, described below.
The
See http://www.bipm.org/en/si/si_brochure/chapter3/prefixes.html.
As
Note these are column-oriented padders, so won't necessarily work
with multi-line output (padding doesn't seem a likely operation for
multi-line output).
If a truncation ellipse is set (e.g. with the
A convenience control structure can be useful in combination with
these states:
Many of the previously mentioned combinators have behavior which can
be altered with state variables. Although
will return the string
would return
Note that fixed point formatting supports arbitrary precision in
implementations with exact non-integral rationals. When trying to
print inexact numbers more than the machine precision you will
typically get results like
but with an exact rational it will give you as many digits as you
request:
would output
would output
outputs
assuming a 16-char width (the left side gets half the width, or 8
spaces, and is left aligned). Note that we explicitly use DSP instead
of the strings directly. This is because
would output
You may also prefix any column with any of the symbols
You can further prefix any column with a width modifier. Any
positive integer is treated as a fixed width, ignoring the available
width. Any real number between 0 and 1 indicates a fraction of the
available width (after subtracting out any fixed widths). Columns
with unspecified width divide up the remaining width evenly.
Note that
As an implementation detail,
where
outputs
The Unix
There are two approaches to using the C formatting extensions -
procedural and sexp-oriented (described in 6.7). In the
procedural interface, C operators are made available as formatters
with a "c-" prefix, literals are converted to their C equivalents and
symbols are output as-is (you're responsible for making sure they are
valid C identifiers). Indentation is handled automatically.
outputs
In addition, the formatter knows when you're in an expression and
when you're in a statement, and behaves accordingly, so that
outputs
Similary,
Moreover, we also keep track of the final expression in a function
and insert returns for you:
outputs
although it knows that void functions don't return.
Switch statements insert breaks by default if they don't return:
though you can explicitly fallthrough if you want:
Operators are available with just a "c" prefix, e.g. c+, c-, c*, c/,
etc.
Function applications are written with
When a C formatter encounters an object it doesn't know how to write
(including lists and records), it outputs them according to the
format state's current
If the
Macros can be handled with
As with all C formatters, the CPP output is pretty printed as
needed, and if it wraps over several lines the lines are terminated
with a backslash.
To write a C header file that is included at most once, you can wrap
the entire body in
The C formatters also respect the
Types are just typically just symbols, or lists of symbols such as
These can also accessed as %fun and %prototype at the head of a list.
Typically a type is just a symbol such as
Pointers may be written as
Unamed structs, classes, unions and enums may be used directly as
types, using their respective keywords at the head of a list.
Two special types are the %array type and function pointer type. An
array is written:
where
A function pointer is written:
For example:
Wherever a type is expected but not given, the value of the
Type declarations work uniformly for variables and parameters, as well
for casts and typedefs.
Rather than building formatting closures by hand, it can be more
convenient to just build a normal s-expression and ask for it to be
formatted as C code. This can be thought of as a simple Scheme->C
compiler without any runtime support.
In a s-expression, strings and characters are printed as C strings and
characters, booleans are printed as 0 or 1, symbols are displayed
as-is, and numbers are printed as C numbers (using the current
formatting radix if specified). Vectors are printed as
comma-separated lists wrapped in braces, which can be used for
initializing arrays or structs.
A list indicates a C expression or statement. Any of the existing C
keywords can be used to pretty-print the expression as described with
the c-keyword formatters above. Thus, the example above
could also be written
C constructs that are dependent on the underlying syntax and have no
keyword are written with a % prefix (
For example, the following definition of the fibonacci sequence, which
apart from the return type of
prints the working C definition:
and more generally
where color can be a symbol name or
can be used to mark the format state as being inside HTML, which the
above color formats will understand and output HTML
It also recognizes and ignores ANSI escapes, in particular useful if
you want to combine this with the fmt-color utilities.
1 Table of Contents
2 Installation
Available for Chicken as the fmt egg, providing the fmt,
fmt-c, fmt-color and fmt-unicode extensions. To install
manually for Chicken just run "chicken-setup" in the fmt
directory.
"make gauche && make install-gauche". The modules
are installed as text.fmt, text.fmt.c, text.fmt.color and
text.fmt.unicode.
fmt.plt yourself
from:
fmt.plt for yourself you can run "make mzscheme".
fmt-scheme48.scm:
> ,config ,load fmt-scheme48.scm
> ,open fmt
(load "let-optionals.scm") ; if you don't have LET-OPTIONALS*
(load "read-line.scm") ; if you don't have READ-LINE
(load "string-ports.scm") ; if you don't have CALL-WITH-OUTPUT-STRING
(load "make-eq-table.scm")
(load "mantissa.scm")
(load "fmt.scm")
(load "fmt-pretty.scm") ; optional pretty printing
(load "fmt-column.scm") ; optional columnar output
(load "fmt-c.scm") ; optional C formatting utilities
(load "fmt-color.scm") ; optional color utilities
(load "fmt-unicode.scm") ; optional Unicode-aware formatting,
; also requires SRFI-4 or SRFI-66
3 Background
There are several approaches to text formatting. Building strings to
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 display and 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.
printf and CL's
format) or pattern matching (as in Visual Basic's Format,
Perl6's 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 SRFI-28 and
SRFI-48.
4 Usage
The primary interface is the fmt procedure:
(fmt <output-dest> <format> ...)
<output-dest> has the same semantics as with format -
specifically it can be an output-port, #t to indicate the current
output port, or #f to accumulate output into a string.
<format> should be a format closure as discussed below. As a
convenience, non-procedure arguments are also allowed and are
formatted similar to display, so that
(fmt #f "Result: " res nl)
"Result: 42n", assuming RES is bound
to 42.
nl is the newline format combinator.
5 Specification
The procedure names have gone through several variations, and I'm
still open to new suggestions. The current approach is to use
abbreviated forms of standard output procedures when defining an
equivalent format combinator (thus display becomes dsp and
write becomes wrt), and to use an fmt- prefix for
utilities and less common combinators. Variants of the same formatter
get a /<variant> suffix.
5.1 Formatting Objects
(dsp <obj>)
Outputs <obj> using display semantics. Specifically, strings
are output without surrounding quotes or escaping and characters are
written as if by write-char. Other objects are written as with
write (including nested strings and chars inside <obj>). This
is the default behavior for top-level formats in fmt, cat and
most other higher-order combinators.
(wrt <obj>)
Outputs <obj> using write semantics. Handles shared
structures as in SRFI-38.
(wrt/unshared <obj>)
As above, but doesn't handle shared structures. Infinite loops can
still be avoided if used inside a combinator that truncates data (see
trim and fit below).
(pretty <obj>)
Pretty-prints <obj>. Also handles shared structures. Unlike many
other pretty printers, vectors and data lists (lists that don't begin
with a (nested) symbol), are printed in tabular format when there's
room, greatly saving vertical space.
(pretty/unshared <obj>)
As above but without sharing.
(slashified <str> [<quote-ch> <esc-ch> <renamer>])
Outputs the string <str>, escaping any quote or escape characters.
If <esc-ch> is #f escapes only the <quote-ch> by
doubling it, as in SQL strings and CSV values. If <renamer> is
provided, it should be a procedure of one character which maps that
character to its escape value, e.g. #\newline => #\n, or #f if
there is no escape value.
(fmt #f (slashified "hi, "bob!""))
=> "hi, "bob!""
(maybe-slashified <str> <pred> [<quote-ch> <esc-ch> <renamer>])
Like slashified, but first checks if any quoting is required (by
the existence of either any quote or escape characters, or any
character matching <pred>), and if so outputs the string in quotes
and with escapes. Otherwise outputs the string as is.
(fmt #f (maybe-slashified "foo" char-whitespace? #\"))
=> "foo"
(fmt #f (maybe-slashified "foo bar" char-whitespace? #\"))
=> ""foo bar""
(fmt #f (maybe-slashified "foo"bar"baz" char-whitespace? #\"))
=> ""foo"bar"baz""
5.2 Formatting Numbers
(num <n> [<radix> <precision> <sign> <comma> <comma-sep> <decimal-sep>])
Formats a single number <n>. You can optionally specify any
<radix> from 2 to 36 (even if <n> isn't an integer).
<precision> forces a fixed-point format.
<sign> of #t indicates to output a plus sign (+) for positive
integers. However, if <sign> is a character, it means to wrap the
number with that character and its mirror opposite if the number is
negative. For example, #\( prints negative numbers in parenthesis,
financial style: -3.14 => (3.14)
<comma> is an integer specifying the number of digits between
commas. Variable length, as in subcontinental-style, is not yet
supported.
<comma-sep> is the character to use for commas, defaulting to #\,.
<decimal-sep> is the character to use for decimals, defaulting to
#\., or to #\, (European style) if <comma-sep> is already
#\..
(num/comma <n> [<base> <precision> <sign>])
Shortcut for num to print with commas.
(fmt #f (num/comma 1234567))
=> "1,234,567"
(num/si <n> [<base> <suffix>])
Abbreviates <n> with an SI suffix as in the -h or --si option to
many GNU commands. The base defaults to 1024, using suffix names
like Ki, Mi, Gi, etc. Other bases (e.g. the standard 1000) have the
suffixes k, M, G, etc.
<suffix> argument is appended only if an abbreviation is used.
(fmt #f (num/si 608))
=> "608"
(fmt #f (num/si 3986))
=> "3.9Ki"
(fmt #f (num/si 3986 1000 "B"))
=> "4kB"
(num/fit <width> <n> . <ARGS>)
Like num, but if the result doesn't fit in <width>, output
instead a string of hashes (with the current <precision>) rather
than showing an incorrectly truncated number. For example
(fmt #f (fix 2 (num/fit 4 12.345)))
=> "#.##"
(num/roman <n>)
Formats the number as a Roman numeral:
(fmt #f (num/roman 1989))
=> "MCMLXXXIX"
(num/old-roman <n>)
Formats the number as an old-style Roman numeral, without the
subtraction abbreviation rule:
(fmt #f (num/old-roman 1989))
=> "MDCCCCLXXXVIIII"
5.3 Formatting Space
nl
Outputs a newline.
fl
Short for "fresh line," outputs a newline only if we're not already
at the start of a line.
(space-to <column>)
Outputs spaces up to the given <column>. If the current column is
already >= <column>, does nothing.
(tab-to [<tab-width>])
Outputs spaces up to the next tab stop, using tab stops of width
<tab-width>, which defaults to 8. If already on a tab stop, does
nothing. If you want to ensure you always tab at least one space, you
can use (cat " " (tab-to width)).
fmt-null
Outputs nothing (useful in combinators and as a default noop in
conditionals).
5.4 Concatenation
(cat <format> ...)
Concatenates the output of each <format>.
(apply-cat <list>)
Equivalent to (apply cat <list>) but may be more efficient.
(fmt-join <formatter> <list> [<sep>])
Formats each element <elt> of <list> with (<formatter>
<elt>), inserting <sep> in between. <sep> defaults to the
empty string, but can be any format.
(fmt #f (fmt-join dsp '(a b c) ", "))
=> "a, b, c"
(fmt-join/prefix <formatter> <list> [<sep>])
(fmt-join/suffix <formatter> <list> [<sep>])
(fmt #f (fmt-join/prefix dsp '(usr local bin) "/"))
=> "/usr/local/bin"
fmt-join, but inserts <sep> before/after every element.
(fmt-join/last <formatter> <last-formatter> <list> [<sep>])
As fmt-join, but the last element of the list is formatted with
<last-formatter> instead.
(fmt-join/dot <formatter> <dot-formatter> <list> [<sep>])
As fmt-join, but if the list is a dotted list, then formats the dotted
value with <dot-formatter> instead.
5.5 Padding and Trimming
(pad <width> <format> ...)
(pad/left <width> <format> ...)
(pad/both <width> <format> ...)
Analogs of SRFI-13 string-pad, these add extra space to the left,
right or both sides of the output generated by the <format>s to
pad it to <width>. If <width> is exceeded has no effect.
pad/both will include an extra space on the right side of the
output if the difference is odd.
pad does not accumulate any intermediate data.
(trim <width> <format> ...)
(trim/left <width> <format> ...)
(trim/both <width> <format> ...)
Analogs of SRFI-13 string-trim, truncates the output of the
<format>s to force it in under <width> columns. As soon as
any of the <format>s exceed <width>, stop formatting and
truncate the result, returning control to whoever called trim. If
<width> is not exceeded has no effect.
ellipses procedure
below), then when any truncation occurs trim and trim/left
will append and prepend the ellipse, respectively. trim/both will
both prepend and append. The length of the ellipse will be considered
when truncating the original string, so that the total width will
never be longer than <width>.
(fmt #f (ellipses "..." (trim 5 "abcde")))
=> "abcde"
(fmt #f (ellipses "..." (trim 5 "abcdef")))
=> "ab..."
(trim/length <width> <format> ...)
A variant of trim which acts on the actual character count rather
than columns, useful for truncating potentially cyclic data.
(fit <width> <format> ...)
(fit/left <width> <format> ...)
(fit/both <width> <format> ...)
A combination of pad and trunc, ensures the output width is
exactly <width>, truncating if it goes over and padding if it goes
under.
5.6 Format Variables
You may have noticed many of the formatters are aware of the current
column. This is because each combinator is actually a procedure of
one argument, the current format state, which holds basic
information such as the row, column, and any other information that
a format combinator may want to keep track of. The basic interface
is:
(fmt-let <name> <value> <format> ...)
(fmt-bind <name> <value> <format> ...)
fmt-let sets the name for the duration of the <format>s, and
restores it on return. fmt-bind sets it without restoring it.
(fmt-if <pred> <pass> [<fail>])
<pred> takes one argument (the format state) and returns a boolean
result. If true, the <pass> format is applied to the state,
otherwise <fail> (defaulting to the identity) is applied.
fmt-let and fmt-bind
could be used, these common variables have shortcuts:
(radix <k> <format> ...)
(fix <k> <format> ...)
These alter the radix and fixed point precision of numbers output with
dsp, wrt, pretty or num. These settings apply
recursively to all output data structures, so that
(fmt #f (radix 16 '(70 80 90)))
"(#x46 #x50 #x5a)". Note that read/write
invariance is essential, so for dsp, wrt and pretty the
radix prefix is always included when not decimal. Use num if you
want to format numbers in alternate bases without this prefix. For
example,
(fmt #f (radix 16 "(" (fmt-join num '(70 80 90) " ") ")"))
"(46 50 5a)", the same output as above without the
"#x" radix prefix.
(fmt #f (fix 30 #i2/3))
=> "0.666666666666666600000000000000"
(fmt #f (fix 30 2/3))
=> "0.666666666666666666666666666667"
(decimal-align <k> <format> ...)
Specifies an alignment for the decimal place when formatting numbers,
useful for outputting tables of numbers.
(define (print-angles x)
(fmt-join num (list x (sin x) (cos x) (tan x)) " "))
(fmt #t (decimal-align 5 (fix 3 (fmt-join/suffix print-angles (iota 5) nl))))
0.000 0.000 1.000 0.000
1.000 0.842 0.540 1.557
2.000 0.909 -0.416 -2.185
3.000 0.141 -0.990 -0.142
4.000 -0.757 -0.654 1.158
(comma-char <k> <format> ...)
(decimal-char <k> <format> ...)
comma-char and decimal-char set the defaults for number
formatting.
(pad-char <k> <format> ...)
The pad-char sets the character used by space-to, tab-to,
pad/*, and fit/*, and defaults to #\space.
(define (print-table-of-contents alist)
(define (print-line x)
(cat (car x) (space-to 72) (pad/left 3 (cdr x))))
(fmt #t (pad-char #\. (fmt-join/suffix print-line alist nl))))
(print-table-of-contents
'(("An Unexpected Party" . 29)
("Roast Mutton" . 60)
("A Short Rest" . 87)
("Over Hill and Under Hill" . 100)
("Riddles in the Dark" . 115)))
An Unexpected Party.....................................................29
Roast Mutton............................................................60
A Short Rest............................................................87
Over Hill and Under Hill...............................................100
Riddles in the Dark....................................................115
(ellipse <ell> <format> ...)
Sets the truncation ellipse to <ell>, would should be a string or
character.
(with-width <width> <format> ...)
Sets the maximum column width used by some formatters. The default
is 78.
5.7 Columnar Formatting
Although tab-to, space-to and padding can be used to manually
align columns to produce table-like output, these can be awkward to
use. The optional extensions in this section make this easier.
(columnar <column> ...)
Formats each <column> side-by-side, i.e. as though each were
formatted separately and then the individual lines concatenated
together. The current column width is divided evenly among the
columns, and all but the last column are right-padded. For example
(fmt #t (columnar (dsp "abcndefn") (dsp "123n456n")))
abc 123
def 456
columnar treats raw
strings as literals inserted into the given location on every line, to
be used as borders, for example:
(fmt #t (columnar "/* " (dsp "abcndefn")
" | " (dsp "123n456n")
" */"))
/* abc | 123 */
/* def | 456 */
'left,
'right or 'center to control the justification. The symbol
'infinite can be used to indicate the column generates an infinite
stream of output.
columnar builds its output incrementally, interleaving
calls to the generators until each has produced a line, then
concatenating that line together and outputting it. This is important
because as noted above, some columns may produce an infinite stream of
output, and in general you may want to format data larger than can fit
into memory. Thus columnar would be suitable for line numbering a
file of arbitrary size, or implementing the Unix yes(1) command,
etc.
columnar uses first-class
continuations to interleave the column output. The core fmt
itself has no knowledge of or special support for columnar, which
could complicate and potentially slow down simpler fmt operations.
This is a testament to the power of call/cc - it can be used to
implement coroutines or arbitrary control structures even where they
were not planned for.
(fmt-columns <column> ...)
The low-level formatter on which columnar is based. Each <column>
must be a list of 2-3 elements:
(<line-formatter> <line-generator> [<infinite?>])
<line-generator> is the column generator as above, and the
<line-formatter> is how each line is formatted. Raw concatenation
of each line is performed, without any spacing or width adjustment.
<infinite?>, if true, indicates this generator produces an
infinite number of lines and termination should be determined without
it.
(wrap-lines <format> ...)
Behaves like cat, except text is accumulated and lines are optimally
wrapped to fit in the current width as in the Unix fmt(1) command.
(justify <format> ...)
Like wrap-lines except the lines are full-justified.
(define func
'(define (fold kons knil ls)
(let lp ((ls ls) (acc knil))
(if (null? ls) acc (lp (cdr ls) (kons (car ls) acc))))))
(define doc
(string-append
"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 #t (columnar (pretty func) " ; " (justify doc)))
(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-file <pathname>)
Simply displayes the contents of the file <pathname> a line at a
time, so that in typical formatters such as columnar only constant
memory is consumed, making this suitable for formatting files of
arbitrary size.
(line-numbers [<start>])
A convenience utility, just formats an infinite stream of numbers (in
the current radix) beginning with <start>, which defaults to 1.
nl(1) utility could be implemented as:
(fmt #t (columnar 6 'right 'infinite (line-numbers)
" " (fmt-file "read-line.scm")))
1
2 (define (read-line . o)
3 (let ((port (if (pair? o) (car o) (current-input-port))))
4 (let lp ((res '()))
5 (let ((c (read-char port)))
6 (if (or (eof-object? c) (eqv? c #\newline))
7 (list->string (reverse res))
8 (lp (cons c res)))))))
6 C Formatting
6.1 C Formatting Basics
For purposes such as writing wrappers, code-generators, compilers or
other language tools, people often need to generate or emit C code.
Without a decent library framework it's difficult to maintain proper
indentation. In addition, for the Scheme programmer it's tedious to
work with all the context sensitivities of C, such as the expression
vs. statement distinction, special rules for writing preprocessor
macros, and when precedence rules require parenthesis. Fortunately,
context is one thing this formatting library is good at keeping
track of. The C formatting interface tries to make it as easy as
possible to generate C code without getting in your way.
(fmt #t (c-if 1 2 3))
if (1) {
2;
} else {
3;
}
(fmt #t (c-if (c-if 1 2 3) 4 5))
if (1 ? 2 : 3) {
4;
} else {
5;
}
c-begin, used for sequencing, will separate with
semi-colons in a statement and commas in an expression.
(fmt #t (c-fun 'int 'foo '() (c-if (c-if 1 2 3) 4 5)))
int foo () {
if (1 ? 2 : 3) {
return 4;
} else {
return 5;
}
}
(fmt #t (c-switch 'y
(c-case 1 (c+= 'x 1))
(c-default (c+= 'x 2))))
switch (y) {
case 1:
x += 1;
break;
default:
x += 2;
break;
}
(fmt #t (c-switch 'y
(c-case/fallthrough 1 (c+= 'x 1))
(c-default (c+= 'x 2))))
switch (y) {
case 1:
x += 1;
default:
x += 2;
break;
}
c++ is a prefix operator, c++/post is postfix. ||, | and
|= are written as c-or, c-bit-or and c-bit-or= respectively.
c-apply. Other control
structures such as c-for and c-while work as expected. The full
list is in the procedure index below.
'gen variable. This allows you to specify
generators for your own types, e.g. if you are using your own AST
records in a compiler.
'gen variable isn't set it defaults to the c-expr/sexp
procedure, which formats an s-expression as if it were C code. Thus
instead of c-apply you can just use a list. The full API is
available via normal s-expressions - formatters that aren't keywords
in C are prefixed with a % or otherwise made invalid C identifiers so
that they can't be confused with function application.
6.2 C Preprocessor Formatting
C preprocessor formatters also properly handle their surrounding
context, so you can safely intermix them in the normal flow of C
code.
(fmt #t (c-switch 'y
(c-case 1 (c= 'x 1))
(cpp-ifdef 'H_TWO (c-case 2 (c= 'x 4)))
(c-default (c= 'x 5))))
switch (y) {
case 1:
x = 1;
break;
#ifdef H_TWO
case 2:
x = 4;
break;
#endif /* H_TWO */
default:
x = 5;
break;
}
cpp-define, which knows to wrap
individual variable references in parenthesis:
(fmt #t (cpp-define '(min x y) (c-if (c< 'x 'y) 'x 'y)))
#define min(x, y) (((x) < (y)) ? (x) : (y))
cpp-wrap-header:
(fmt #t (cpp-wrap-header "FOO_H"
(c-extern (c-prototype 'int 'foo '()))))
#ifndef FOO_H
#define FOO_H
extern int foo ();
#endif /* ! FOO_H */
6.3 Customizing C Style
The output uses a simplified K&R style with 4 spaces for indentation
by default. The following state variables let you override the
style:
'indent-space
how many spaces to indent bodies, default 4
'switch-indent-space
how many spaces to indent switch clauses, also defaults to 4
'newline-before-brace?
insert a newline before an open brace (non-K&R), defaults to #f
'braceless-bodies?
omit braces when we can prove they aren't needed
'non-spaced-ops?
omit spaces between operators and operands for groups of variables and
literals (e.g. "a+b+3" instead of "a + b + 3"}
'no-wrap?
Don't wrap function calls and long operator groups over mulitple
lines. Functions and control structures will still use multiple
lines.
'radix and 'precision settings.
6.4 C Formatter Index
(c-if <condition> <pass> [<fail> [<condition2> <pass2> ...]])
Print a chain of if/else conditions. Use a final condition of 'else
for a final else clause.
(c-for <init> <condition> <update> <body> ...)
(c-while <condition> <body> ...)
Basic loop constructs.
(c-fun <type> <name> <params> <body> ...)
(c-prototype <type> <name> <params>)
Output a function or function prototype. The parameters should be a
list 2-element lists of the form (<param-type> <param-name>),
which are output with DSP. A parameter can be abbreviated as just the
symbol name, or #f can be passed as the type, in which case the
'default-type state variable is used. The parameters may be a
dotted list, in which case ellipses for a C variadic are inserted -
the actual name of the dotted value is ignored.
'(const char). A complete description is given below in section
6.6.
(c-var <type> <name> [<init-value>])
Declares and optionally initializes a variable. Also accessed as %var
at the head of a list.
(c-begin <expr> ...)
Outputs each of the <expr>s, separated by semi-colons if in a
statement or commas if in an expression.
(c-switch <clause> ...)
(c-case <values> <body> ...)
(c-case/fallthrough <values> <body> ...)
(c-default <body> ...)
Switch statements. In addition to using the clause formatters,
clauses inside a switch may be handled with a Scheme CASE-like list,
with the car a list of case values and the cdr the body.
(c-label <name>)
(c-goto <name>)
(c-return [<result>])
c-break
c-continue
Manual labels and jumps. Labels can also be accessed as a list
beginning with a colon, e.g. '(: label1).
(c-const <expr>)
(c-static <expr>)
(c-volatile <expr>)
(c-restrict <expr>)
(c-register <expr>)
(c-auto <expr>)
(c-inline <expr>)
(c-extern <expr>)
Declaration modifiers. May be nested.
(c-extern/C <body> ...)
Wraps body in an extern "C" { ... } for use with C++.
(c-cast <type> <expr>)
Casts an expression to a type. Also %cast at the head of a list.
(c-typedef <type> <new-name> ...)
Creates a new type definition with one or more names.
(c-struct [<name>] <field-list> [<attributes>])
(c-union [<name>] <field-list> [<attributes>])
(c-class [<name>] <field-list> [<attributes>])
(c-attribute <values> ...)
Composite type constructors. Attributes may be accessed as
%attribute at the head of a list.
(fmt #f (c-struct 'employee
'((short age)
((char *) name)
((struct (year month day)) dob))
(c-attribute 'packed)))
struct employee {
short age;
char* name;
struct {
int year;
int month;
int day;
} dob;
} __attribute__ ((packed));
(c-enum [<name>] <enum-list>)
Enumerated types. <enum-list> may be strings, symbols, or lists of
string or symbol followed by the enum's value.
(c-comment <formatter> ...)
Outputs the <formatter>s wrapped in C's /* ... */ comment. Properly
escapes nested comments inside in an Emacs-friendly style.
6.5 C Preprocessor Formatter Index
(cpp-include <file>)
If file is a string, outputs in it "quotes", otherwise (as a symbol
or arbitrary formatter) it outputs it in brackets.
(fmt #f (cpp-include 'stdio.h))
=> "#include <stdio.h>n"
(fmt #f (cpp-include "config.h"))
=> "#include "config.h"n"
(cpp-define <macro> [<value>])
Defines a preprocessor macro, which may be just a name or a list of
name and parameters. Properly wraps the value in parenthesis and
escapes newlines. A dotted parameter list will use the C99 variadic
macro syntax, and will also substitute any references to the dotted
name with __VA_ARGS__:
(fmt #t (cpp-define '(eprintf . args) '(fprintf stderr args)))
#define eprintf(...) (fprintf(stderr, __VA_ARGS__))
(cpp-if <condition> <pass> [<fail> ...])
(cpp-ifdef <condition> <pass> [<fail> ...])
(cpp-ifndef <condition> <pass> [<fail> ...])
(cpp-elif <condition> <pass> [<fail> ...])
(cpp-else <body> ...)
Conditional compilation.
(cpp-line <num> [<file>])
Line number information.
(cpp-pragma <args> ...)
(cpp-error <args> ...)
(cpp-warning <args> ...)
Additional preprocessor directives.
(cpp-stringify <expr>)
Stringifies <expr> by prefixing the # operator.
(cpp-sym-cat <args> ...)
Joins the <args> into a single preprocessor token with the ##
operator.
(cpp-wrap-header <name> <body> ...)
Wrap an entire header to only be included once.
Operators:
c++ c-- c+ c- c* c/ c% c& c^ c~ c! c&& c<< c>> c== c!=
c< c> c<= c>= c= c+= c-= c*= c/= c%= c&= c^= c<<= c>>=
c++/post c--/post c-or c-bit-or c-bit-or=
6.6 C Types
'char or 'int. You
can wrap types with modifiers such as c-const, but as a
convenience you can just use a list such as in '(const unsignedchar *).
You can also nest these lists, so the previous example is
equivalent to '(* (const (unsigned char))).
'(%pointer <type>) for readability -
%pointer is exactly equivalent to * in types.
(%array <type> [<size>])
<type> is any other type (including another array or
function pointer), and <size>, if given, will print the array
size. For example:
(c-var '(%array (unsigned long) SIZE) 'table '#(1 2 3 4))
unsigned long table[SIZE] = {1, 2, 3, 4};
(%fun <return-type> (<param-types> ...))
(c-typedef '(%fun double (double double int)) 'f)
typedef double (*f)(double, double, int);
'default-type formatting state variable is used. By default this
is just 'int.
6.7 C as S-Expressions
(fmt #t (c-if (c-if 1 2 3) 4 5))
(fmt #t (c-expr '(if (if 1 2 3) 4 5)))
%fun, %var, %pointer,
%array, %cast), including C preprocessor constructs
(%include, %define, %pragma, %error, %warning,
%if, %ifdef, %ifndef, %elif). Labels are written as
(: <label-name>). You can write a sequence as (%begin <expr>
...).
#f looks like a Lisp definition:
(fmt #t (c-expr '(%fun #f fib (n)
(if (<= n 1)
1
(+ (fib (- n 1)) (fib (- n 2)))))))
int fib (int n) {
if (n <= 1) {
return 1;
} else {
return fib((n - 1)) + fib((n - 2));
}
}
7 Formatting with Color
The fmt-color library provides the following utilities:
(fmt-red <formatter> ...)
(fmt-blue <formatter> ...)
(fmt-green <formatter> ...)
(fmt-cyan <formatter> ...)
(fmt-yellow <formatter> ...)
(fmt-magenta <formatter> ...)
(fmt-white <formatter> ...)
(fmt-black <formatter> ...)
(fmt-bold <formatter> ...)
(fmt-underline <formatter> ...)
(fmt-color <color> <formatter> ...)
#xRRGGBB numeric value.
Outputs the formatters colored with ANSI escapes. In addition
(fmt-in-html <formatter> ...)
<span> tags with
the appropriate style colors, instead of ANSI escapes.
8 Unicode
The fmt-unicode library provides the fmt-unicode formatter, which
just takes a list of formatters and overrides the string-length for
padding and trimming, such that Unicode double or full width
characters are considered 2 characters wide (as they typically are in
fixed-width terminals), while treating combining and non-spacing
characters as 0 characters wide.
| format | fmt |
| ~a | dsp |
| ~c | dsp |
| ~s | wrt/unshared |
| ~w | wrt |
| ~y | pretty |
| ~x | (radix 16 ...) or (num <n> 16) |
| ~o | (radix 8 ...) or (num <n> 8) |
| ~b | (radix 2 ...) or (num <n> 2) |
| ~f | (fix <digits> ...) or (num <n> <radix> <digits>) |
| ~% | nl |
| ~& | fl |
| ~[...~] | normal if or fmt-if (delayed test) |
| ~{...~} | (fmt-join ... <list> [<sep>]) |
11 References
[1] R. Kelsey, W. Clinger, J. Rees (eds.)
Revised^5 Report on the Algorithmic Language Scheme
[2] Guy L. Steele Jr. (editor) Common Lisp Hyperspec
[3] Scott G. Miller SRFI-28 Basic Format Strings
[4] Ken Dickey SRFI-48 Intermediate Format Strings
[5] Ray Dillinger SRFI-38 External Representation for Data With Shared Structure
[6] Damian Conway Perl6 Exegesis 7 - formatting
#|-------------------- 0.704 |# "./fmt.meta" 472
;;; fmt.meta -*- Hen -*-
((egg "fmt.egg")
(synopsis "Combinator Formatting")
(license "BSD")
(category io)
(author "Alex Shinn")
(doc-from-wiki)
(needs utf8)
(test-depends test)
(files "fmt.setup" "fmt.html" "fmt-unicode-chicken.scm" "fmt-color.scm" "test-fmt.scm" "fmt.meta" "fmt-c.scm" "test-fmt-c.scm" "fmt-c-chicken.scm" "fmt-color-chicken.scm" "fmt-pretty.scm" "README.chicken" "fmt-chicken.scm" "test-round.scm" "fmt-column.scm" "tests/run.scm" "fmt.scm"))
#|-------------------- 0.704 |# "./fmt.scm" 44121
;;;; fmt.scm -- extensible formatting library
;;
;; Copyright (c) 2006-2009 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
;; (require-extension (srfi 1 6 13 23 69))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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 #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-decimal-align st) (vector-ref st 10))
(define (fmt-string-width st) (vector-ref st 11))
(define (fmt-ellipses st) (vector-ref st 12))
(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-decimal-align! st x) (vector-set! st 10 x) st)
(define (fmt-set-string-width! st x) (vector-set! st 11 x) st)
(define (fmt-set-ellipses! st x) (vector-set! st 12 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))
((decimal-align) (fmt-decimal-align 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))
((decimal-align) (fmt-set-decimal-align! 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 (decimal-align n . ls) (fmt-let 'decimal-align n (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)))
(define default-digits
(list->vector (string->list "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ")))
;; kanji (10 included for base 11 ;)
;; (vector "０" "一" "二" "三" "四" "五" "六" "七" "八" "九" "十")
;; old style kanji:
;; (vector "零" "壱" "弐" "参" "肆" "伍" "陸" "柒" "捌" "玖" "拾")
;; 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?))
(align (fmt-decimal-align st))
(digit-vec default-digits)
(stack '()))
(define (write-digit d)
(display (vector-ref digit-vec (inexact->exact (truncate d))) port))
;; 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. Alas, if it weren't for
;; decimals and commas, we could just keep track of the last
;; non-9 digit and the number of nines seen, without any need
;; for a heap-allocated stack.
(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)))
(define (write-prefix prefix align k)
(if align
(let* ((prefix (cond ((string? prefix) prefix)
((char? prefix) (string prefix))
(else "")))
(diff (- align
(+ (if (zero? k) 1 k) (string-length prefix))
1)))
(if (positive? diff)
(display (make-string diff (fmt-pad-char st)) port))
(display prefix port))
(if prefix (display prefix port))))
(define (write-real n prefix align)
(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 (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-digit 0)
(lp (- i 1))))))
(define (pad-all d i)
(cond
((>= d base)
(flush/rounded))
(else
(flush)
(write-digit d)))
(let lp ((i (- i 1)))
(cond
((> i 0)
(if (and commify? (zero? (modulo i comma-rule)))
(display comma-sep port))
(write-digit 0)
(lp (- i 1)))
((and (= i 0) (inexact? n))
(display decimal-sep port)
(write-digit 0)))))
;;(define (pad-sci d i k)
;; (cond
;; ((>= d base)
;; (flush/rounded))
;; (else
;; (flush)
;; (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 (and (bigger (+ r m+) s)) ;; (or digits (>= k -4))
(lead r s m+ m- (+ k 1))
(lead (* r base) s (* m+ base) (* m- base) k)))
(define (lead r s m+ m- k)
(write-prefix prefix align k)
(cond
((and (not digits) (or (> k 14) (< k -4)))
(write n port)) ; XXXX native write for sci
;;((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)))
(else
(cond
((and (not digits)
(or (negative? k)
(and (zero? k) (not (integer? n)))))
(write-digit 0)
(display decimal-sep port)
(let lp ((i 0))
(cond ((> i k)
(write-digit 0)
(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)
(output decimal-sep))
((and commify?
(positive? i)
(zero? (modulo i comma-rule)))
(output comma-sep)))
(let ((d (quotient r s))
(r (remainder r s)))
(if (not (smaller r m-))
(cond
((not (bigger (+ r m+) s))
(output 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))))))
(define (generate-fixed r s m+ m- k)
(if (<= k 0)
(set! stack (append (make-list (min (- k) digits) 0)
(list decimal-sep 0))))
(let ((i0 (- (+ k digits) 1)))
(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)
(cond
((>= d (- base 1))
(flush/rounded)
(pad 0 i))
(else
(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))
;; (output 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.0 (- e)) 2) 1 1 0 f e)
(scale (* f 2 2) (* (expt 2.0 (- 1 e)) 2) 2 1 0 f e)))
(else
(if (= f *bot-f*)
(let ((be (expt 2 e)))
(scale (* f be 2) 2.0 be be 0 f e))
(let* ((be (expt 2 e)) (be1 (* be 2)))
(scale (* f be1 2) (* 2.0 2) be1 be 0 f e)))))))
(define (write-fixed-rational p prefix align)
(define (get-scale q) (expt base (- (integer-log q base) 1)))
(let ((n (numerator p))
(d (denominator p))
(k (integer-log p base)))
(write-prefix prefix align k)
(let lp ((n n)
(i (- k)))
(cond
((< i digits)
(if (zero? i) (output decimal-sep))
(let ((q (quotient n d)))
(cond
((>= q base)
(let* ((scale (get-scale q))
(digit (quotient q scale))
(n2 (- n (* d digit scale))))
(output digit)
(lp n2 (+ i 1))))
(else
(output q)
(lp (* (remainder n d) base) (+ i 1))))))
(else
(let* ((q (quotient n d))
(digit
(* 2 (if (>= q base) (quotient q (get-scale q)) q))))
(if (or (> digit base)
(and (= digit base)
(let ((prev (find integer? stack)))
(and prev (odd? prev)))))
(flush/rounded)
(flush))))))))
(define (wrap-sign n sign? align writer)
(cond
((negative? n)
(cond
((char? sign?)
(writer (abs n) sign? align)
(display (mirror-of sign?) port))
(else
(writer (abs n) #\- align))))
(else
(cond
((and sign? (not (char? sign?)))
(writer n #\+ align))
(else
(writer n #f align))))))
(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 (exact? n) (not (integer? n)))
(cond
(digits
(wrap-sign n sign? align write-fixed-rational))
(else
(wrap-sign (numerator n) sign? #f write-real)
(write-char #\/ port)
(wrap-sign (denominator n) #f #f write-real))))
(else
(wrap-sign n sign? align write-real))))
(else (wrap-sign (real-part n) sign? #f write-real)
(wrap-sign imag #t #f write-real)
(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)))))))
(define roman-numerals
'((1000 . #\M) (500 . #\D) (100 . #\C)
(50 . #\L) (10 . #\X) (5 . #\V) (1 . #\I)))
(define (num/old-roman num)
(lambda (st)
(let lp ((num num) (res '()))
(if (positive? num)
(let ((ch (find (lambda (x) (>= num (car x))) roman-numerals)))
(lp (- num (car ch)) (cons (cdr ch) res)))
(fmt-write (reverse-list->string res) st)))))
(define (num/roman num)
(lambda (st)
(let lp1 ((num num) (res '()))
(if (positive? num)
(let lp2 ((ls roman-numerals))
(let* ((big (car ls))
(big-n (car big)))
(cond
((>= num big-n)
(lp1 (- num big-n) (cons (cdr big) res)))
((and (> (* 2 num) big-n)
(find (lambda (c)
(let ((x (car c)))
(<= (+ x 1) (- big-n x) num)))
ls))
=> (lambda (c)
(lp1 (- num (- big-n (car c)))
(cons (cdr big) (cons (cdr c) res)))))
(else
(lp2 (cdr ls))))))
(fmt-write (reverse-list->string res) st)))))
;; 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))
(not (fmt-decimal-align 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)))
#|-------------------- 0.704 |# "./fmt.setup" 924
(define version "0.704")
(compile -s -O2 -d0 -j fmt -o fmt.so fmt-chicken.scm)
(compile -s -O2 -d0 fmt.import.scm)
(install-extension
'fmt
'("fmt.so" "fmt.import.so")
`((version ,version) (documentation "fmt.html")))
(compile -s -O2 -d0 -j fmt-c -o fmt-c.so fmt-c-chicken.scm)
(compile -s -O2 -d0 fmt-c.import.scm)
(install-extension
'fmt-c
'("fmt-c.so" "fmt-c.import.so")
`((version ,version) (documentation "fmt.html")))
(compile -s -O2 -d0 -j fmt-color -o fmt-color.so fmt-color-chicken.scm)
(compile -s -O2 -d0 fmt-color.import.scm)
(install-extension
'fmt-color
'("fmt-color.so" "fmt-color.import.so")
`((version ,version) (documentation "fmt.html")))
(compile -s -O2 -f -d0 -j fmt-unicode -o fmt-unicode.so fmt-unicode-chicken.scm)
(compile -s -O2 -d0 fmt-unicode.import.scm)
(install-extension
'fmt-unicode
'("fmt-unicode.so" "fmt-unicode.import.so")
`((version ,version) (documentation "fmt.html")))
#|-------------------- 0.704 |# "./test-fmt-c.scm" 9169
(cond-expand
(chicken (use test) (use fmt fmt-c))
(gauche
(use gauche.test)
(use text.fmt)
(use text.fmt.c)
(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)))
)))
(else))
(test-begin "fmt-c")
(test "if (1) {
2;
} else {
3;
}
"
(fmt #f (c-if 1 2 3)))
(test "if (x ? y : z) {
2;
} else {
3;
}
"
(fmt #f (c-if (c-if 'x 'y 'z) 2 3)))
(test "int square (int x) {
return x * x;
}
"
(fmt #f (c-fun 'int 'square '((int x)) (c* 'x 'x))))
(test "int foo (int x, int y, int z) {
if (x ? y : z) {
return 2;
} else {
return 3;
}
}
"
(fmt #f (c-fun 'int 'foo '((int x) (int y) (int z))
(c-if (c-if 'x 'y 'z) 2 3))))
(test "void bar (int mode, const char *msg, unsigned int arg) {
if (mode == 1) {
printf(msg);
} else {
printf(msg, arg);
}
}
"
(fmt #f (c-fun 'void 'bar
'((int mode)
((%pointer (const char)) msg)
((unsigned int) arg))
(c-if (c== 'mode 1) '(printf msg) '(printf msg arg)))))
(test "while ((line = readline()) != EOF) {
printf(\"%s\", line);
}
"
(fmt #f (c-while (c!= (c= 'line '(readline)) 'EOF)
'(printf "%s" line))))
(test "switch (y) {
case 1:
x = 1;
break;
case 2:
x = 4;
break;
default:
x = 5;
break;
}
"
(fmt #f (c-switch 'y
(c-case 1 (c= 'x 1))
(c-case 2 (c= 'x 4))
(c-default (c= 'x 5)))))
(test "switch (y) {
case 1:
x = 1;
break;
case 2:
x = 4;
default:
x = 5;
break;
}
"
(fmt #f (c-switch 'y
(c-case 1 (c= 'x 1))
(c-case/fallthrough 2 (c= 'x 4))
(c-default (c= 'x 5)))))
(test "switch (y) {
case 1:
x = 1;
break;
case 2:
x = 4;
break;
default:
x = 5;
break;
}
"
(fmt #f (c-switch 'y '((1) (= x 1)) '((2) (= x 4)) '(else (= x 5)))))
(test "switch (y) {
case 1:
x = 1;
break;
case 2:
x = 4;
break;
default:
x = 5;
break;
}
"
(fmt #f (c-expr '(switch y ((1) (= x 1)) ((2) (= x 4)) (else (= x 5))))))
(test "int q (int x) {
switch (x) {
case 1:
return 1;
case 2:
return 4;
default:
return 5;
}
}
"
(fmt #f (c-fun 'int 'q '(x) (c-switch 'x '((1) 1) '((2) 4) '(else 5)))))
(test "for (i = 0; i < n; i++) {
printf(\"i: %d\");
}
"
(fmt #f (c-for (c= 'i 0) (c< 'i 'n) (c++/post 'i) '(printf "i: %d"))))
(test "a * x + b * y == c;\n"
(fmt #f (c== (c+ (c* 'a 'x) (c* 'b 'y)) 'c)))
(test "a * x + b * y == c;\n"
(fmt #f (c-expr '(== (+ (* a x) (* b y)) c))))
(test "(a + x) * (b + y) == c;\n"
(fmt #f (c-expr '(== (* (+ a x) (+ b y)) c))))
(test
"(abracadabra!!!! + xylophone????)
* (bananarama____ + yellowstonepark~~~~)
* (cryptoanalysis + zebramania);\n"
(fmt #f (c-expr '(* (+ abracadabra!!!! xylophone????)
(+ bananarama____ yellowstonepark~~~~)
(+ cryptoanalysis zebramania)))))
(test
"abracadabra(xylophone,
bananarama,
yellowstonepark,
cryptoanalysis,
zebramania,
delightful,
wubbleflubbery);\n"
(fmt #f (c-expr '(abracadabra xylophone
bananarama
yellowstonepark
cryptoanalysis
zebramania
delightful
wubbleflubbery))))
(test "#define foo(x, y) (((x) + (y)))\n"
(fmt #f (cpp-define '(foo (int x) (int y)) (c+ 'x 'y))))
(test "#define min(x, y) (((x) < (y)) ? (x) : (y))\n"
(fmt #f (cpp-define '(min x y) (c-if (c< 'x 'y) 'x 'y))))
(test
"#define foo(x, y) (abracadabra(((x) + (y)), \\
xylophone, \\
bananarama, \\
yellowstonepark, \\
cryptoanalysis, \\
zebramania, \\
delightful, \\
wubbleflubbery))\n"
(fmt #f (cpp-define '(foo x y)
'(abracadabra (+ x y)
xylophone
bananarama
yellowstonepark
cryptoanalysis
zebramania
delightful
wubbleflubbery))))
(test "#ifndef FOO_H
#define FOO_H
extern int foo ();
#endif /* ! FOO_H */
"
(fmt #f (cpp-wrap-header
'FOO_H
(c-extern (c-prototype 'int 'foo '())))))
(test "/* this is a /\\* nested *\\/ comment */"
(fmt #f (c-comment " this is a " (c-comment " nested ") " comment ")))
;; the initial leading space is annoying but hard to remove at the
;; moment - the important thing is we preserve indentation in the body
(test "switch (y) {
case 1:
x = 1;
break;
#ifdef H_TWO
case 2:
x = 4;
break;
#endif /* H_TWO */
default:
x = 5;
break;
}
"
(fmt #f (c-expr
`(switch y
((1) (= x 1))
,(cpp-ifdef 'H_TWO (c-case '(2) '(= x 4)))
(else (= x 5))))))
(test "#define eprintf(...) (fprintf(stderr, __VA_ARGS__))\n"
(fmt #f (c-expr '(%define (eprintf . args) (fprintf stderr args)))))
(test "struct point {
int x;
int y;
};
"
(fmt #f (c-expr `(struct point (x y)))))
(test "struct employee {
short age;
char *name;
struct {
int year;
int month;
int day;
} dob;
} __attribute__ ((packed));
"
(fmt #f (c-expr `(struct employee
((short age)
((%pointer char) name)
((struct (year month day)) dob))
(%attribute packed)
))))
(test "class employee {
short age;
char *name;
struct {
int year;
int month;
int day;
} dob;
} __attribute__ ((packed));
"
(fmt #f (c-class 'employee
'((short age)
((%pointer char) name)
((struct (year month day)) dob))
(c-attribute 'packed)
)))
(test "union object {
char tag;
struct {
char tag;
char *data;
} string;
struct {
char tag;
void *car;
void *cdr;
} pair;
struct {
char tag;
unsigned int length;
void *data;
} vector;
};
"
(fmt #f (c-expr
'(union object
((char tag)
((struct ((char tag) ((* char) data))) string)
((struct ((char tag)
((* void) car)
((* void) cdr)))
pair)
((struct ((char tag)
((unsigned int) length)
((* void) data)))
vector)
)))))
(test "enum type_tags {
TYPE_CHAR = 1,
TYPE_FIXNUM,
TYPE_BOOLEAN,
TYPE_NULL,
TYPE_EOF,
TYPE_STRING,
TYPE_PAIR,
TYPE_VECTOR
};
"
(fmt #f (c-expr '(enum type_tags ((TYPE_CHAR 1) TYPE_FIXNUM TYPE_BOOLEAN TYPE_NULL TYPE_EOF TYPE_STRING TYPE_PAIR TYPE_VECTOR)))))
(test "#define OP_EVAL 0xFE\n" (fmt #f (radix 16 (cpp-define 'OP_EVAL 254))))
(test "unsigned long table[SIZE] = {1, 2, 3, 4};\n"
(fmt #f (c-var '(%array (unsigned long) SIZE) 'table '#(1 2 3 4))))
(test "int *array_of_ptr[];\n"
(fmt #f (c-var '(%array (* int)) 'array_of_ptr)))
(test "int (*ptr_to_array)[];\n"
(fmt #f (c-var '(* (%array int)) 'ptr_to_array)))
(test "foo **table = {{1, \"foo\"}, {2, \"bar\"}, {3, \"baz\"}, {4, \"qux\"}};\n"
(fmt #f (c-var '(* (* foo)) 'table
'#(#(1 "foo") #(2 "bar") #(3 "baz") #(4 "qux")))))
(test "sexp (*f)(sexp, sexp) = NULL;\n"
(fmt #f (c-var '(%fun sexp (sexp sexp)) 'f 'NULL)))
(test "sexp (*)(sexp) (*f)(sexp, sexp) = NULL;\n"
(fmt #f (c-var '(%fun (%fun sexp (sexp)) (sexp sexp)) 'f 'NULL)))
(test "typedef double (*f)(double *, double, int);\n"
(fmt #f (c-typedef '(%fun double ((* double) double int)) 'f)))
(test-end)
#|-------------------- 0.704 |# "./test-fmt.scm" 18979
(cond-expand
(chicken (use test) (use 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)
(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-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 "-1" (fmt #f (num -1)))
(test "0" (fmt #f (num 0)))
(test "1" (fmt #f (num 1)))
(test "10" (fmt #f (num 10)))
(test "100" (fmt #f (num 100)))
;; (test "1e+15" (fmt #f (num 1e+15)))
;; (test "1e+23" (fmt #f (num 1e+23)))
;; (test "1.2e+23" (fmt #f (num 1.2e+23)))
;; (test "1e-5" (fmt #f (num 1e-5)))
;; (test "1e-6" (fmt #f (num 1e-6)))
;; (test "1e-7" (fmt #f (num 1e-7)))
;; (test "2e-6" (fmt #f (num 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 "0.000004" (fmt #f (num 0.000004 10 6)))
(test "0.0000040" (fmt #f (num 0.000004 10 7)))
(test "0.00000400" (fmt #f (num 0.000004 10 8)))
;; (test "0.000004" (fmt #f (num 0.000004)))
(test " 3.14159" (fmt #f (decimal-align 5 (num 3.14159))))
(test " 31.4159" (fmt #f (decimal-align 5 (num 31.4159))))
(test " 314.159" (fmt #f (decimal-align 5 (num 314.159))))
(test "3141.59" (fmt #f (decimal-align 5 (num 3141.59))))
(test "31415.9" (fmt #f (decimal-align 5 (num 31415.9))))
(test " -3.14159" (fmt #f (decimal-align 5 (num -3.14159))))
(test " -31.4159" (fmt #f (decimal-align 5 (num -31.4159))))
(test "-314.159" (fmt #f (decimal-align 5 (num -314.159))))
(test "-3141.59" (fmt #f (decimal-align 5 (num -3141.59))))
(test "-31415.9" (fmt #f (decimal-align 5 (num -31415.9))))
(cond
((exact? (/ 1 3)) ;; exact rationals
(test "333.333333333333333333333333333333" (fmt #f (fix 30 1000/3)))
(test "33.333333333333333333333333333333" (fmt #f (fix 30 100/3)))
(test "3.333333333333333333333333333333" (fmt #f (fix 30 10/3)))
(test "0.333333333333333333333333333333" (fmt #f (fix 30 1/3)))
(test "0.033333333333333333333333333333" (fmt #f (fix 30 1/30)))
(test "0.003333333333333333333333333333" (fmt #f (fix 30 1/300)))
(test "0.000333333333333333333333333333" (fmt #f (fix 30 1/3000)))
(test "0.666666666666666666666666666667" (fmt #f (fix 30 2/3)))
(test "0.090909090909090909090909090909" (fmt #f (fix 30 1/11)))
(test "1.428571428571428571428571428571" (fmt #f (fix 30 10/7)))
(test "0.123456789012345678901234567890"
(fmt #f (fix 30 (/ 123456789012345678901234567890
1000000000000000000000000000000))))
(test " 333.333333333333333333333333333333" (fmt #f (decimal-align 5 (fix 30 1000/3))))
(test " 33.333333333333333333333333333333" (fmt #f (decimal-align 5 (fix 30 100/3))))
(test " 3.333333333333333333333333333333" (fmt #f (decimal-align 5 (fix 30 10/3))))
(test " 0.333333333333333333333333333333" (fmt #f (decimal-align 5 (fix 30 1/3))))
))
(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 <>) (string-split "abcdef\n123456\n" "\n") 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)))))
(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
"((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 "\n" (fmt #f (wrap-lines " ")))
(test "foo abc def ghi \n jkl mno \n"
(fmt #f (with-width 20 (columnar 6 (dsp "foo") (wrap-lines "abc def ghi jkl mno")))))
(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
"- Item 1: The text here is
indented according
to the space \"Item
1\" takes, and one
does not known what
goes here.
"
(fmt #f (columnar 9 (dsp "- Item 1:") " " (with-width 20 (wrap-lines "The text here is indented according to the space \"Item 1\" takes, and one does not known what goes here.")))))
(test
"- Item 1: The text here is
indented according
to the space \"Item
1\" takes, and one
does not known what
goes here.
"
(fmt #f (columnar 9 (dsp "- Item 1:\n") " " (with-width 20 (wrap-lines "The text here is indented according to the space \"Item 1\" takes, and one does not known what goes here.")))))
(test
"- Item 1: The text here is----------------------------------------------------
--------- indented according--------------------------------------------------
--------- to the space \"Item--------------------------------------------------
--------- 1\" takes, and one---------------------------------------------------
--------- does not known what-------------------------------------------------
--------- goes here.----------------------------------------------------------
"
(fmt #f (pad-char #\- (columnar 9 (dsp "- Item 1:\n") " " (with-width 20 (wrap-lines "The text here is indented according to the space \"Item 1\" takes, and one does not known what goes here."))))))
(test
"abc-----------------
"
(fmt #f (pad-char #\- (with-width 20 (columnar (dsp "abc"))))))
;; 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))
(test-end)
#|-------------------- 0.704 |# "./test-round.scm" 705
(use fmt test)
;;(use numbers) ; test with and without numbers via -R numbers
(define (check-representation n)
(define pence
(inexact->exact (round (/ (modulo n 1000) 10))))
(define pounds (quotient n 1000))
(if (> pence 99)
(begin
(set! pence (- 100 pence))
(set! pounds (add1 pounds))))
(define expected-result
(cond
((= pence 0) (sprintf "~S.00" pounds))
((< pence 10) (sprintf "~S.0~S" pounds pence))
(else (sprintf "~S.~S" pounds pence))))
(test (sprintf "~S = ~S?" (exact->inexact (/ n 1000)) expected-result)
expected-result
(fmt #f (num (/ n 1000) 10 2))))
(test-begin)
(for-each check-representation (iota 10000))
(test-end)