Title

Formatting (Converting All Types of Object to A String)

Author

Joo ChurlSoo

Abstract

The SRFI introduces three procedures; one formatter procedure and two general
purpose procedures.  The formatter procedure is the CAT procedure that
converts any object to a string.  It takes one object as the first argument
and accepts a variable number of optional arguments, unlike the procedure
called FORMAT.  One of the two general procedures is the CONCAT procedure with
a variable number of arguments that concatenates the arguments after
converting them to strings.  The other is the PRINT procedure with a variable
number of arguments that prints those arguments on current output port.

Rationale

It is difficult to gain a complete consensus for the design of a generic
formatting procedure that performs a variety of necessary functions in
addition to essential functions provided in C's PRINTF and Common lisp's
FORMAT.  One of such ways would be to devise a free (and/or floating) sequence
method that easily handles optional arguments, in contrast to the conventional
fixed sequence method, in order to obtain a handy optional and functional
interface.  With the concept of free sequencing, the CAT procedure is then
defined, not to process optional arguments with default values, but to process
default values with optional arguments.

Issues

In converting a number to a string, it has not been tried to uniformly express
the exactness of a number in all implementations as each implementation
supports a varying degree of numerical types in R5RS.  The CAT procedure makes
it possible for the user to prefix exact sign to the resulting string as well
as not to prefix it to the resulting string as conventionally used, when an
exact number is made to have a decimal point, or an inexact number is
converted to an exact number that has a decimal point.

Specification

(CAT <object> [[<width@>] [<char@>] [<converter@>] [<exactness%>] [<radix%>]
	       [<precision%>] [<sign%>] [<separator%>] [<writer$>] [<pipe$>]
	       [<take$>] [<override$>] [<string@>] ...])

     * <suffix@>: effective for all types of <object>.
       <suffix%>: effective only for the number type of <object>.
       <suffix$>: effective for all types except the number type of <object>.
     * <object> is any scheme object.
     * <width> is an exact integer whose absolute value specifies the width of
       the resulting string.  When the resulting string has fewer characters
       than the absolute value of <width>, it is placed rightmost with the
       rest being padded with <char>s, if <width> is positive, or it is placed
       leftmost with the rest being padded with <char>s, if <width> is
       negative.  On the other hand, when the resulting string has more
       characters than the absolute value of <width>, the <width> is ignored.
       The default value is 0.
     * <char> is a padding character.  The default value is #\space.
     * <converter> is a pair whose car value is a predicate procedure that
       checks whether <object> satisfies it, and cdr value is a procedure that
       takes the <object> as the first argument with or without a variable
       number of optional arguments and returns a string.  When <object>
       satisfies the predicate procedure, all optional arguments are
       ineffective except <width>, <char>, and <string>s.
     * <exactness> is a symbol: exact or inexact.
     * <radix> is a symbol: binary, decimal, octal, or hexadecimal.
       The default value is decimal.
     * <precision> is an inexact integer whose absolute value specifies the
       number of decimal digits after a decimal point.  If <precision> is
       a non-negative integer, an exact sign (#e) is prefixed to the resulting
       string as needed.
     * If <sign> is a symbol that takes the form of 'sign, and <object> is a
       positive number without a positive sign, the positive sign is prefixed
       to the resulting string.
     * <separator> is a list whose first element is a character serving as a
       separator and second element is a positive exact integer.  If the
       integer is n, the resulting string is separated in every n-characters
       of the resulting string.  When the integer is omitted, the default
       value is 3.
     * <writer> is a procedure of two arguments; <object> and a string port.
       It writes <object> to the string port.  The default value of <writer>
       is varied according to the type of <object>.  When <object> is a
       self-evaluating constant, it becomes equivalent to DISPLAY procedure,
       otherwise, it becomes WRITE procedure.  If you want any objects to
       be displayed in your own way, you have to define your own <writer>.
       Otherwise, they are displayed simply in their evaluated forms.
     * <pipe> is a list which is composed of one or more procedures.  Each
       procedure takes at least one string argument and returns a string.  One
       procedure connects with another as a pipe.
     * <take> is a list whose elements are two exact integers; n and m, and
       the absolute values of n and m are N and M, respectively.
       First, the resulting string takes from the left n-characters, if it is
       non-negative, or all the characters but N-characters, if negative.
       Second, it takes from the right m-characters, if it is non-negative, or
       all the characters but M-characters, if negative.  Then, it
       concatenates two set of characters taken.
     * <override> is a list whose first element is an exact integer that
       overrides <width>, second being a character that overrides <char>, and
       the last being strings that override <string>s.  The character and
       strings can be omitted.  If omitted, the default values of the
       character and strings are <char> and <string>s, respectively.
     * <string> is a string that is appended to the resulting string.

The order of all optional arguments does not matter.  The CAT procedure
processes optional arguments in the following order; <converter>, <exactness>,
<radix>, <precision>, <sign>, <separator>, <char>, <width>, <string> for the
number type of <object>, or in the following order; <converter>, <writer>,
<pipe>, <take>, <char>, <width>, <string>, <override> for all other types.

(CONCAT [<object>] ...)
(PRINT  [<object>] ...)

     * <object> is any scheme object.

CONCAT concatenates <object>s after converting them to strings and PRINT
prints <object>s on current output port.  When <object> is a self-evaluating
constant, they use DISPLAY procedure, otherwise, use WRITE procedure.

Examples

(cat 129.995 -10 2.)				"130.00    "
(cat 129.995 2. 10)				"    130.00"
(cat 129.995 2. 'exact)				"#e130.00"
(cat 129 -2.)					"129.00"
(cat 129 2.)					"#e129.00"
(cat 129 10 2. #\0)				"#e00129.00"
(cat 129 10 2. #\9 'sign)			"#e+9129.00"
(cat 129 10 2. #\* 'sign)			"*#e+129.00"
(cat 1/3)					"1/3"
(cat 1/3 10 2.)					"    #e0.33"
(cat 1/3 10 -2.)				"      0.33"
(cat 129.995 10 '(#\, 2))			" 1,29.99,5"
(cat 129995 10 '(#\,) 'sign)			"  +129,995"
(cat (cat 129.995 0.) '(0 -1))			"130"
(cat (cat 129.995) '(3 0))			"129"
(cat 99.5 10 'sign 'octal 'exact)		"    +307/2"
(cat (sqrt -5) 10 2.)				"0.00+2.24i"
(cat 3.14159e12 10 2. 'sign)			"  +3.14e12"
(cat #x123 'octal 'sign)			"+443"
(cat "#o" (cat #x123 'octal 'sign))		"#o+443"
(cat #x123 -10 2. 'sign #\*)			"#e+291.00*"
(cat "string" -10)				"string    "
(cat "string" 10 (list string-upcase))		"    STRING"
(cat "string" 10 (list string-upcase) '(-2 0))	"      RING"
(cat "string" 10 `(,string-titlecase) '(2 3))	"     Sting"
(cat "string" 10 #\*
     `(,string-upcase ,(cut substring <> 1 5))) "******TRIN"
(cat "string" 10
     `(,string-reverse ,string-upcase) '(1 4))	"     GIRTS"
(cat #\a 10)					"         a"
(cat 'symbol 10)				"    symbol"
(cat '#(12 #\a "str" sym '(a)))			"#(12 #\\a \"str\" sym '(a))"
(cat '(12 #\a "str" sym '(a)))			"(12 #\\a \"str\" sym '(a))"
(concat '(12 #\a "str" sym '(a)))		"(12 #\\a \"str\" sym '(a))"
(print '(12 #\a "str" sym '(a)))		(12 #\a "str" sym '(a))
(cat 123 " " (cat #\a) " str "
     (cat "string" write) " " (cat 'symbol))	"123 a str \"string\" symbol"
(concat 123 " " #\a " str "
	(cat "string" write) " " 'symbol)	"123 a str \"string\" symbol"
(print 123 " " #\a " str "
       (cat "string" write) " " 'symbol)	123 a str "string" symbol

(define-record-type :example
    (make-example num str)
    example?
    (num get-num set-num!)
    (str get-str set-str!))
(define ex (make-example 123 "string"))
(define (record->string object)
  (concat (get-num object) "-" (get-str object)))
(define (record-writer object string-port)
    (if (example? object)
	(begin (display (get-num object) string-port)
	       (display "-" string-port)
	       (display (get-str object) string-port))
	((or (and (or (string? object)
		      (char? object)
		      (boolean? object))
		  display)
	     write) object string-port))) 
ex						'#{:example}
(cat ex)					"#{:example}"
(cat ex 20 record-writer)			"          123-string"
(cat ex 20 record-writer
     `(,(cut string-delete char-set:digit <>)
       ,string-upcase ,string-reverse)
     '(0 -1) #\-)				"--------------GNIRTS"
(cat "string" 20 record-writer
     (list string-upcase) '(2 3) #\-)		"---------------STING"
(cat 12 20 record-writer 3.)			"            #e12.000"
(cat ex 20 (cons example? record->string))	"          123-string"
(cat ex 20 (cons example? record->string)
     `(,(cut string-delete char-set:digit <>)
       ,string-upcase ,string-reverse)
     '(0 -1) #\-)				"----------123-string"
(cat "string" 20 (cons example? record->string)
     (list string-upcase) '(2 3) #\-)		"---------------STING"
(cat 12 20 (cons example? record->string) -3.)	"              12.000"

(define item '("plus" "minus" "net"))
(define item-values '(234 -123 111))
(define mixed-item '("plus" 234 "minus" -123 "net" 111))
(define item-alist '(("plus" 234) ("minus" -123) ("net" 111)))
(apply print (map (lambda (x y) (cat x 5 ":" (cat y 10 "\n")))
		  item item-values))
 plus:       234
minus:      -123
  net:       111
(apply print (map (lambda (x) (cat (car x) 5 ":" (cat (cadr x) 10 "\n")))
		  item-alist))
 plus:       234
minus:      -123
  net:       111
(apply print (map (cut cat <> 10 "\n" '(5 #\space ":")) mixed-item))
 plus:       234
minus:      -123
  net:       111

(define (simple-ordinal-suffix num)
  (let ((last-two (string->number (cat (cat num) '(0 2))))
	(last-one (string->number (cat (cat num) '(0 1)))))
    (cond
     ((or (= last-two 11) (= last-two 12) (= last-two 13)) "th")
     ((= last-one 1) "st")
     ((= last-one 2) "nd")
     ((= last-one 3) "rd")
     (else "th"))))
(define (predicate num)
  (and (exact? num) (integer? num)))
(define (str-suffix num)
  (concat num (simple-ordinal-suffix num)))
(define (suffix num)
  (if (and (integer? num) (exact? num))
      (simple-ordinal-suffix num) ""))
(define a 2)
(define b 12)
(define c 22)
(cat a (suffix a))				"2nd"
(cat b (suffix b))				"12th"
(cat c (suffix c))				"22nd"
(cat 12.5 (suffix 12.5))			"12.5"
(cat (+ a 1) (cons predicate str-suffix))	"3rd"
(cat (+ b 1) (cons predicate str-suffix))	"13th"
(cat (+ c 1) (cons predicate str-suffix))	"23rd"
(cat 12.5 (cons predicate str-suffix))		"12.5"

Implementation

The implementation below requires SRFI-1 (List library), SRFI-6 (Basic string
ports), SRFI-8 (Receive), SRFI-13 (String library), and SRFI-51 (Handling rest
list).

(define (concat . objects)
  (get-output-string
   (let ((string-port (open-output-string)))
     (for-each (lambda (object)
		 ((or (and (or (number? object)
			       (string? object)
			       (char? object)
			       (boolean? object))
			   display)
		      write)
		  object string-port))
	       objects)
     string-port)))

(define (print . objects)
  (for-each (lambda (object)
	      ((or (and (or (number? object)
			    (string? object)
			    (char? object)
			    (boolean? object))
			display)
		   write)
	       object))
	    objects))

(define (cat object . rest)
  (receive (width char converter exactness radix precision sign separator
	    writer pipe take override . str-list)
      (rest-values rest #f
		   (cons 0 (lambda (x) (and (integer? x) (exact? x))))
		   (cons #\space char?)
		   (cons #f (lambda (x)
			      (and (pair? x)
				   (procedure? (car x))
				   (procedure? (cdr x)))))
		   (cons #f (lambda (x) (memq x '(exact inexact))))
		   (list 'decimal 'binary 'octal 'hexadecimal)
		   (cons #f (lambda (x) (and (integer? x) (inexact? x))))
		   (cons #f (lambda (x) (eq? x 'sign)))
		   (cons #f (lambda (x)
			      (and (list? x)
				   (< 0 (length x) 3)
				   (char? (car x))
				   (or (null? (cdr x))
				       (and (integer? (cadr x))
					    (exact? (cadr x))
					    (< 0 (cadr x)))))))
		   (cons #f procedure?)
		   (cons #f (lambda (x)
			      (and (list? x)
				   (not (null? x))
				   (every procedure? x))))
		   (cons #f (lambda (x)
			      (and (list? x)
				   (= (length x) 2)
				   (every (lambda (x)
					    (and (integer? x) (exact? x)))
					  x))))
		   (cons #f (lambda (x)
			      (and (list? x)
				   (not (null? x))
				   (and (integer? (car x)) (exact? (car x)))
				   (or (null? (cdr x))
				       (and (char? (cadr x))
					    (every string? (cddr x))))))))
    (arg-or "cat: bad argument" str-list (not (every string? str-list)))
    (cond
     ((and converter
	   ((car converter) object))
      (let* ((str ((cdr converter) object))
	     (pad (- (abs width) (string-length str))))
	(apply string-append
	       (cond
		((<= pad 0) str)
		((< 0 width) (string-append (make-string pad char) str))
		(else (string-append str (make-string pad char))))
	       str-list)))
     ((number? object)
      (arg-ors ("cat: non-decimal cannot be inexact" radix
		(and (memq radix '(binary octal hexadecimal))
		     (or precision
			 (and (inexact? object)
			      (not (eq? exactness 'exact)))
			 (eq? exactness 'inexact))))
	       ("cat: cannot be expressed without exact sign" precision
		(and precision
		     (< precision 0)
		     (eq? exactness 'exact))))
      (let* ((exact-sign (and precision
			      (<= 0 precision)
			      (or (eq? exactness 'exact)
				  (and (exact? object)
				       (not (eq? exactness
						 'inexact))))))
	     (str (number->string
		   (if (or (not precision) (<= 0 precision))
		       (if exact-sign
			   (if (exact? object)
			       (exact->inexact object) object)
			   (if exactness
			       (if (eq? exactness 'exact)
				   (if (inexact? object)
				       (inexact->exact object) object)
				   (if (exact? object)
				       (exact->inexact object) object))
			       object))
		       (if exactness
			   (if (eq? exactness 'exact)
			       (if (inexact? object)
				   (inexact->exact object) object)
			       (if (exact? object)
				   (exact->inexact object) object))
			   (if (and precision (exact? object))
			       (exact->inexact object) object)))
		   (cdr (assq radix
			      '((decimal . 10) (binary . 2) (octal . 8)
				(hexadecimal . 16))))))
	     (str (if precision
		      (let ((precision (inexact->exact (abs precision)))
			    (e-index (or (string-index str #\e)
					 (string-index str #\E)))
			    (+-index (or (string-index str #\+ 1)
					 (string-index str #\- 1))))
			(define (mold str pre)
			  (let ((len (string-length str))
				(index (string-index str #\.)))
			    (if index
				(let ((d-len (- len (+ index 1))))
				  (if (<= d-len pre)
				      (string-append
				       str (make-string (- pre d-len) #\0))
				      (mold
				       (number->string
					(let ((num
					       (string->number
						(substring
						 str 0
						 (+ (if (= pre 0) 0 1)
						    index pre)))))
					  ((if (< num 0) - +)
					   num
					   (if (< 4 (string->number
						     (string
						      (string-ref
						       str
						       (+ 1 index pre)))))
					       (expt 0.1 pre) 0))))
				       pre)))
				(string-append str "."
					       (make-string pre #\0)))))
			(cond
			 (e-index
			  (string-append
			   (mold (substring str 0 e-index) precision)
			   (substring str e-index (string-length str))))
			 (+-index
			  (string-append
			   (mold (substring str 0 +-index) precision)
			   (string (string-ref str +-index))
			   (mold (substring str (+ 1 +-index)
					    (- (string-length str) 1))
				 precision)
			   (string (string-ref str (- (string-length str)
						      1)))))
			 (else
			  (mold str precision))))
		      str))
	     (str (if (and (< 0 (real-part object))
			   (not (eqv? #\+ (string-ref str 0)))
			   sign)
		      (string-append "+" str) str))
	     (str (if exact-sign (string-append "#e" str) str))
	     (str (if (and separator
			   (not (or (string-index str #\e)
				    (string-index str #\i)
				    (string-index str #\/))))
		      (let ((sep-str (string (car separator)))
			    (sep-num (if (null? (cdr separator))
					 3 (cadr separator)))
			    (+-sign (and (or (eqv? #\- (string-ref str 0))
					     (eqv? #\+ (string-ref str 0)))
					 (string (string-ref str 0)))))
			(define (list->alist slist n)
			  (if (< (length slist) n)
			      (if (null? slist) '() (list slist))
			      (receive (n-list rest) (split-at slist n)
				(cons n-list (list->alist rest n)))))
			(let* ((str (if +-sign
					(substring str 1 (string-length str))
					str))
			       (dot-index (string-index str #\.))
			       (predot-str-list
				(map reverse-list->string
				     (reverse
				      (list->alist
				       (reverse
					(string->list
					 (if dot-index
					     (substring str 0 dot-index)
					     str)))
				       sep-num))))
			       (postdot-str-list
				(map list->string
				     (list->alist
				      (string->list
				       (if dot-index
					   (substring str (+ 1 dot-index)
						      (string-length str))
					   ""))
				      sep-num))))
			  (string-append (or +-sign "")
					 (string-join predot-str-list sep-str)
					 (if dot-index "." "")
					 (string-join postdot-str-list
						      sep-str))))
		      str))
	     (len (string-length str))
	     (pad (- (abs width) len)))
	(apply string-append
	       (cond
		((<= pad 0) str)
		((< 0 width)
		 (cond
		  ((and (char-numeric? char) exact-sign)
		   (if (or (eqv? #\+ (string-ref str 2))
			   (eqv? #\- (string-ref str 2)))
		       (string-append (substring str 0 3)
				      (make-string pad char)
				      (substring str 3 len))
		       (string-append (substring str 0 2)
				      (make-string pad char)
				      (substring str 2 len))))
		  ((and (char-numeric? char)
			(or (eqv? #\+ (string-ref str 0))
			    (eqv? #\- (string-ref str 0))))
		   (string-append (substring str 0 1)
				  (make-string pad char)
				  (substring str 1 len)))
		  (else
		   (string-append (make-string pad char) str))))
		(else (string-append str (make-string pad char))))
	       str-list)))
     (else
      (let* ((str (get-output-string
		   (let ((str-port (open-output-string)))
		     ((or writer
			  (and (or (string? object)
				   (char? object)
				   (boolean? object))
			       display)
			  write)
		      object str-port)
		     str-port)))
	     (str (if pipe
		      (let loop ((str ((car pipe) str))
				 (procs (cdr pipe)))
			(if (null? procs)
			    str
			    (loop ((car procs) str) (cdr procs))))
		      str))
	     (str
	      (if take
		  (let ((left (car take))
			(right (cadr take))
			(len (string-length str)))
		    (string-append
		     (if (< left 0)
			 (string-drop str (if (< (abs left) len)
					      (abs left) len))
			 (string-take str (if (< left len)
					      left len)))
		     (if (< right 0)
			 (string-drop-right str (if (< (abs right) len)
						    (abs right) len))
			 (string-take-right str (if (< right len)
						    right len)))))
		  str))
	     (width (if override (car override) width))
	     (char (if (and override
			    (not (null? (cdr override))))
		       (cadr override) char))
	     (pad (- (abs width) (string-length str)))
	     (str-list (if (and override
				(not (null? (cdr override)))
				(not (null? (cddr override))))
			   (cddr override)
			   str-list)))
	(apply string-append
	       (cond
		((<= pad 0) str)
		((< 0 width) (string-append (make-string pad char) str))
		(else (string-append str (make-string pad char))))
	       str-list))))))

References

[Print] Mark Feeley: Format strings are wrong. Posting in relation to [SRFI 48]
	on 25-Nov-2003.
	http://srfi.schemers.org/srfi-48/mail-archive/msg00000.html

Copyright

Copyright (C) Joo ChurlSoo (2004). All Rights Reserved.

This document and translations of it may be copied and furnished to others, and
derivative works that comment on or otherwise explain it or assist in its
implementation may be prepared, copied, published and distributed, in whole or
in part, without restriction of any kind, provided that the above copyright
notice and this paragraph are included on all such copies and derivative works.
However, this document itself may not be modified in any way, such as by
removing the copyright notice or references to the Scheme Request For
Implementation process or editors, except as needed for the purpose of
developing SRFIs in which case the procedures for copyrights defined in the
SRFI process must be followed, or as required to translate it into languages
other than English.

The limited permissions granted above are perpetual and will not be revoked by
the authors or their successors or assigns.

This document and the information contained herein is provided on an "AS IS"
basis and THE AUTHOR AND THE SRFI EDITORS DISCLAIM ALL WARRANTIES, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTY THAT THE USE OF THE
INFORMATION HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED WARRANTIES OF
MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
