#lang racket/base
;;; @Package     numformat
;;; @Subtitle    Sketchy Number Formatting in Racket
;;; @HomePage    http://www.neilvandyke.org/racket-numformat/
;;; @Author      Neil Van Dyke
;;; @Version     0.1
;;; @Date        2011-08-23
;;; @PLaneT      neil/numformat:1:=0

;; $Id: numformat.rkt,v 1.61 2011/08/24 02:33:23 neilpair Exp $

;;; @legal
;;; Copyright @copyright{} 2011 Neil Van Dyke.  This program is Software; you
;;; can redistribute it and/or modify it under the terms of the GNU Lesser
;;; General Public License as published by the Free Software Foundation; either
;;; version 3 of the License (LGPL 3), or (at your option) any later version.
;;; This program is distributed in the hope that it will be useful, but without
;;; any warranty; without even the implied warranty of merchantability or
;;; fitness for a particular purpose.  See
;;; @indicateurl{http://www.gnu.org/licenses/} for details.  For other licenses
;;; and consulting, please contact the author.
;;; @end legal

;;; @section Introduction

;;; @i{Warning: This package is known to be incomplete, and probably has bugs.}
;;;
;;; The @b{numformat} package is for writing formatted numbers from Racket.  As
;;; the author recalls, he started writing this package in R5RS Scheme many
;;; years ago, did not finish it, then had an urgent need for writing formatted
;;; numbers from Racket in a small personal script, and so this incomplete
;;; package was pressed into service.  The author has @i{not} used this code in
;;; software developed for consulting clients.  However, since people have
;;; asked over the years for better number formatting from Racket, and this
;;; package might be of assistance, the author finally decided to release this
;;; package despite its relatively poor quality.  Anyone using this package
;;; should pay especially attention to the ``without any warranty'' part of the
;;; legal notices for this package, since, should any person attempt to sue the
;;; author over this package, the author's armada of lawyers will just laugh
;;; and laugh at that person.  Documentation is sparse.

;; TODO: This whole thing could use rewriting from scratch.

;;; @section Interface

(define %numformat:host-negative-sign #\-)

(define %numformat:host-decimal-point #\.)

(define (%numformat:make-do-fractional-part decimal-point
                                            max-fractional-length
                                            pad-fractional-char
                                            pad-fractional-length)
  (lambda (chars out)
    (if (and (or (not pad-fractional-length)
                 (zero? pad-fractional-length))
             (or (null? chars) (equal? chars '(#\0))))
        (void)
        (begin
          (display decimal-point out)
          (if max-fractional-length
              (begin (let loop ((remaining max-fractional-length)
                                (chars     chars))
                       (cond ((null? chars))
                             ((> remaining 0)
                              (write-char (car chars) out)
                              (loop (- remaining 1) (cdr chars)))))
                     ;; TODO: !!! this is a quick kludge.  rewrite this entire
                     ;; function
                     (and pad-fractional-length
                          (let loop-pad ((remaining (- pad-fractional-length
                                                       (length chars))))
                            (and (> remaining 0)
                                 (begin (write-char pad-fractional-char out)
                                        (loop-pad (- remaining 1))))))
                     ;; TODO: possibly pad to pad-fractional-digits
                     )
              (begin
                (for-each (lambda (c) (write-char c out)) chars)
                ;; TODO: possibly pad to pad-fractional-digits
                ))))))

(define (make-do-whole-part/spacers whole-spacers-char
                                    whole-spacers-interval
                                    do-fractional-part)
  (lambda (chars out)
    (let ((chars-after-dot #f))
      ;; Scan the digits of the whole portion of the number, to count them and
      ;; save sublist that's after any decimal point character.  Then display
      ;; the whole portion with spacers.
      (let ((len (let scan-whole ((chars chars)
                                  (len 0))
                   (if (null? chars)
                       len
                       (let ((c (car chars)))
                         (cond ((char-numeric? c)
                                (scan-whole (cdr chars) (+ 1 len)))
                               ((eqv? c %numformat:host-decimal-point)
                                (set! chars-after-dot (cdr chars))
                                len)
                               (else (error '<make-do-whole-part/spacers>
                                            "invalid character ~S"
                                            c))))))))

        ;; TODO: !!! handle whole-spacers-interval = #f

        ;; TODO: !!! handle len = 0 here
        (let loop ((pos       len)
                   (chars     chars)
                   (group-pos #f))
          ;;(printf "\n*DEBUG* group-pos=~S\n" group-pos)
          (and (not (zero? pos))
               (loop (- pos 1)
                     (cdr chars)
                     (cond ((not group-pos)
                            (display (car chars) out)
                            (and whole-spacers-interval
                                 (modulo (- len 1) whole-spacers-interval)))
                           ((zero? group-pos)
                            (display whole-spacers-char out)
                            (display (car chars) out)
                            (- whole-spacers-interval 1))
                           (else
                            (display (car chars) out)
                            (- group-pos 1)))))))
      ;; Now handle any fractional digits.
      (and chars-after-dot
           (do-fractional-part chars-after-dot out)
           ;; TODO: handle case of no chars after dot, but want pad
           ))))

(define-syntax %numformat:make-number-displayer/macro
  (syntax-rules ()
    ((_ sign
        prefix
        pad-whole-char
        pad-whole-length
        whole-spacers-char
        whole-spacers-interval
        decimal-point
        max-fractional-length
        pad-fractional-char
        pad-fractional-length
        suffix)
     (let* ((fractional-proc (%numformat:make-do-fractional-part
                              decimal-point
                              max-fractional-length
                              pad-fractional-char
                              pad-fractional-length))
            (whole-proc      (make-do-whole-part/spacers
                              whole-spacers-char
                              whole-spacers-interval
                              fractional-proc)))
       (lambda (num (out (current-output-port)))
         (let ((chars (string->list (number->string (exact->inexact num))))
               (neg? #f))
           ;; Act on whether number is negative or positive.
           (if (eqv? (car chars) %numformat:host-negative-sign)
               ;; Negative, so...
               (begin (set! neg?  #t)
                      (set! chars (cdr chars))
                      (and (memq sign '(parens parens-spaces))
                           (write-char #\( out))
                      (and prefix (display prefix out))
                      (and (memq sign '(minus plus-minus))
                           (write-char #\- out)))
               ;; Non-negative, so...
               (begin (and (eq? sign 'parens-spaces)
                           (write-char #\space out))
                      (and prefix
                           (display prefix out))
                      (and (eq? sign 'plus-minus)
                           (not (zero? num))
                           (write-char #\+ out))))
           ;; Do bulk of it.
           (whole-proc chars out)
           ;; Closing paren or space.
           (case sign
             ((parens)        (and neg? (write-char #\) out)))
             ((parens-spaces) (write-char (if neg? #\) #\space) out)))))))))

(define %numformat:make-number-displayer/positional
  (lambda (sign
           prefix
           pad-whole-char
           pad-whole-length
           whole-spacers-char
           whole-spacers-interval
           decimal-point
           max-fractional-length
           pad-fractional-char
           pad-fractional-length
           suffix)
    (%numformat:make-number-displayer/macro
     sign
     prefix
     pad-whole-char
     pad-whole-length
     whole-spacers-char
     whole-spacers-interval
     decimal-point
     max-fractional-length
     pad-fractional-char
     pad-fractional-length
     suffix)))

;;; @defproc make-number-displayer specs
;;;
;;; Define a procedure that displays numbers to output ports using formatting
;;; that is customized by the alist in @var{specs}.
;;;
;;; @lisp
;;; (define display-dollars-and-cents
;;;   (make-number-displayer
;;;    '((sign                   parens)
;;;      (prefix                 "$")
;;;      (pad-whole-char         #f)
;;;      (pad-whole-length       #f)
;;;      (whole-spacers-char     #\,)
;;;      (whole-spacers-interval 3)
;;;      (decimal-point          #\.)
;;;      (max-fractional-length  2)
;;;      (pad-fractional-char    #\0)
;;;      (pad-fractional-length  2)
;;;      (suffix                 #f))))
;;;
;;; (display-dollars-and-cents -987654321.69696969)
;;; (newline)
;;; (display-dollars-and-cents 69.01)
;;; (newline)
;;; (display-dollars-and-cents 69.1)
;;; @end lisp
;;;
;;; outputs:
;;;
;;; @example
;;; ($987,654,321.69)
;;; $69.01
;;; $69.10
;;; @end example
;;;
;;; For the possible values in @var{specs}, until those are documented, you'll
;;; have to look at the source code, or experiment.

;; TODO: !!! Document "specs" argument.

(define make-number-displayer
  (letrec ((pc (lambda (x)
                 (cond ((not     x) x)
                       ((char?   x) x)
                       ((string? x) (case (string-length x)
                                      ((0)  #f)
                                      ((1)  (string-ref  x 0))
                                      (else (error 'make-number-displayer
                                                   "pc: invalid string x=~S"
                                                   x))))
                       (else (error 'make-number-displayer
                                    "pc: invalid x=~S type"
                                    x)))))
           (p0 (lambda (x)
                 (if (or (not x) (and (integer? x) (>= x 0)))
                     x
                     (error 'make-number-displayer
                            "p0: expected x=~S to be #f or integer >= 0"
                            x))))
           (p1 (lambda (x)
                 (if (or (not x) (and (integer? x) (>= x 1)))
                     x
                     (error 'make-number-displayer
                            "p1: expected x=~S to be #f or integer >= 1" x))))
           (ps (lambda (x)
                 (cond ((not     x) x)
                       ((char?   x) x)
                       ((string? x) (case (string-length x)
                                      ((0)  #f)
                                      ((1)  (string-ref  x 0))
                                      (else (string-copy x))))
                       (else (error 'make-number-displayer
                                    "ps: invalid x=~S type"
                                    x)))))
           (pe (lambda (x acceptable)
                 (if (memv x acceptable)
                     x
                     (error 'make-number-displayer
                            "pe: x=~S is not acceptable"
                            x)))))
    (lambda (specs)
      (let ((sign                   'minus)
            (prefix                 #f)
            (pad-whole-char         #f)
            (pad-whole-length       #f)
            (whole-spacers-char     #f)
            (whole-spacers-interval #f)
            (decimal-point          #\.)
            (max-fractional-length  #f)
            (pad-fractional-char    0)
            (pad-fractional-length  #f)
            (suffix                 #f))
        (for-each
         (lambda (item)
           (or (and (list? item) (= (length item) 2))
               (error 'make-number-displayer
                      "spec attributes must be list of 2 elements: ~S"
                      item))
           (let ((attr (car  item))
                 (v    (cadr item)))
             (case attr
               ((sign)
                (set! sign (pe v '(minus plus-minus parens parens-spaces))))
               ((prefix)                 (set! prefix                 (ps v)))
               ((pad-whole-char)         (set! pad-whole-char         (pc v)))
               ((pad-whole-length)       (set! pad-whole-length       (p1 v)))
               ((whole-spacers-char)     (set! whole-spacers-char     (pc v)))
               ((whole-spacers-interval) (set! whole-spacers-interval (p1 v)))
               ((decimal-point)          (set! decimal-point          (ps v)))
               ((max-fractional-length)  (set! max-fractional-length  (p0 v)))
               ((pad-fractional-char)    (set! pad-fractional-char    (pc v)))
               ((pad-fractional-length)  (set! pad-fractional-length  (p1 v)))
               ((suffix)                 (set! suffix                 (ps v)))
               (else (error 'make-number-displayer
                            "invalid spec attribute name: ~S"
                            attr)))))
         specs)
        ;; TODO: Error-check interdependencies.
        (%numformat:make-number-displayer/positional
         sign
         prefix
         pad-whole-char
         pad-whole-length
         whole-spacers-char
         whole-spacers-interval
         decimal-point
         max-fractional-length
         pad-fractional-char
         pad-fractional-length
         suffix)))))

;;; @defproc  display-number/us-style num [ out ]
;;; @defprocx display-number/european-style num [ out ]
;;;
;;; Write number @var{num} to output port @var{out}, using some formatting
;;; conventions of a particular locale.  If @var{out} is not given, defaults to
;;; the value of @code{(current-output-port)}.
;;;
;;; For example:
;;;
;;; @lisp
;;; (define x -987654321.6969697)
;;; (display-number/us-style x)
;;; (newline)
;;; (display-number/european-style x)
;;; @end lisp
;;;
;;; outputs:
;;;
;;; @example
;;; -987,654,321.6969697
;;; -987'654'321,6969697
;;; @end example

(define display-number/us-style
  (make-number-displayer
   '((whole-spacers-char     #\,)
     (whole-spacers-interval 3)
     (decimal-point          #\.))))

(define display-number/european-style
  (make-number-displayer
   '((whole-spacers-char     #\')
     (whole-spacers-interval 3)
     (decimal-point          #\,))))

;; TODO: Look at Java 2 "java.text.DecimalFormat".
;;       http://java.sun.com/j2se/1.4.2/docs/api/java/text/DecimalFormat.html

;; TODO: Maybe document the correspondence with XSL "xsl:decimal-format" and
;;       "format-number".

;; TODO: What about infinity.

;; TODO: Make separate procedure to construct exponential-format numbers.
;;       Or add properties for it to the normal constructor, and do lots of
;;       error-checking for setting of mutually-exclusive properties.

;; TODO: Look at localization SRFI-29
;;       http://srfi.schemers.org/srfi-29/srfi-29.html

;; TODO: Add min-whole-digits, and let it be as low as 0.  In case of 0, may
;;       have to strip 0 from host format.

;;; @unnumberedsec History

;;; @table @asis
;;;
;;; @item Version 0.1 --- 2011-08-23 --- PLaneT @code{(1 0)}
;;; Initial release of some old, buggy code.
;;;
;;; @end table

(provide make-number-displayer
         display-number/us-style
         display-number/european-style)