#!r6rs
;;; FILE       "intermediate-format-strings.sls"
;;; IMPLEMENTS SRFI-48: Intermediary format strings
;;;            http://srfi.schemers.org/srfi-48/srfi-48.html
;;; AUTHOR     Ken Dickey
;;; UPDATED    Syntax updated for R6RS February 2008 by Ken Dickey
;;; LANGUAGE   R6RS

;; Small changes by Derick Eddington to the beginning of `format'.

;;;Copyright (C) Kenneth A Dickey (2003). All Rights Reserved.
;;;
;;;Permission is hereby granted, free of charge, to any person
;;;obtaining a copy of this software and associated documentation
;;;files (the "Software"), to deal in the Software without
;;;restriction, including without limitation the rights to use,
;;;copy, modify, merge, publish, distribute, sublicense, and/or
;;;sell copies of the Software, and to permit persons to whom
;;;the Software is furnished to do so, subject to the following
;;;conditions:
;;;
;;;The above copyright notice and this permission notice shall
;;;be included in all copies or substantial portions of the Software.
;;;
;;;THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;;EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
;;;OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;;NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;;HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;;WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;;FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
;;;OTHER DEALINGS IN THE SOFTWARE.

; The implementation below requires SRFI-6 (Basic string ports), 
; and SRFI-38 (External Representation for Data With Shared Structure). 
 
(library (srfi srfi-48)
  (export 
    format)
  (import
    (rnrs)
    (srfi :48 intermediate-format-strings compat)
    (srfi :6  basic-string-ports)
    (srfi :38 with-shared-structure))
  
  (define ascii-tab #\tab)
    
  (define (format arg0 . arg*)
    
    (define (problem msg . irts)
      (apply assertion-violation 'format msg irts))
    
    (define (_format port format-string args return-value)      

      (define (string-index str c)
        (let ( [len (string-length str)] )
          (let loop ( [i 0] )
            (cond ((= i len) #f)
                  ((eqv? c (string-ref str i)) i)
                  (else (loop (+ i 1)))))))
      
      (define (string-grow str len char)
        (let ( [off (- len (string-length str))] )
          (if (positive? off)
            (string-append (make-string off char) str)
            str)))
      
(define (compose-with-digits digits pre-str frac-str exp-str)
        (let ( [frac-len (string-length frac-str)] )
;;@@DEBUG
;;(format #t "~%@@(compose-with-digits digits=~s pre-str=~s frac-str=~s exp-str=~s ) ~%" digits pre-str frac-str exp-str)
          (cond	
            [(< frac-len digits) ;; grow frac part, pad with zeros
             (string-append pre-str "."
                            frac-str (make-string (- digits frac-len) #\0)
                            exp-str)
             ]
            [(= frac-len digits) ;; frac-part is exactly the right size
             (string-append pre-str "."
                            frac-str
                            exp-str)
             ]
            [else ;; must round to shrink frac-part
             (let* ( [first-part (substring frac-str 0 digits)]
                     [last-part  (substring frac-str digits frac-len)]
                     ;; NB: Scheme uses "Round to Even Rule" for .5
                     [rounded-frac
		     ;; NB: exact is r6; r5 is inexact->exact
                      (exact (round (string->number
                                        (string-append first-part "." last-part))))
                      ]
		     [rounded-frac-str (number->string rounded-frac)]
                     [rounded-frac-len (string-length rounded-frac-str)]
                     [carry? (and (not (zero? rounded-frac))
                                  (> rounded-frac-len digits))
                      ]
                     [new-frac
                      (let ( (pre-frac
                              (if carry? ;; trim leading "1"
                                  (substring rounded-frac-str 1 (min rounded-frac-len digits))
                                  (substring rounded-frac-str 0 (min rounded-frac-len digits))) ;; may be zero length
                              )
                           )
                        (if (< (string-length pre-frac) digits)
                            (string-grow pre-frac digits #\0)
                            pre-frac))
                      ]
                    )
;;@@DEBUG
;;(format #t "@@ first-part=~s last-part=~s rounded-frac=~s carry?=~s ~%" first-part last-part rounded-frac carry?)
               (string-append
                (if carry? (number->string (+ 1 (string->number pre-str))) pre-str)
                "."
                new-frac
                exp-str))]
            ) ) )
      
      
      (define (format-fixed number-or-string width digits) ; returns a string
;;@@DEBUG
;;(format #t "~%(format-fixed number-or-string=~s width=~s digits=~s)~%" number-or-string width digits)

        (cond
          [(string? number-or-string)
           (string-grow number-or-string width #\space)
           ]
          [(number? number-or-string)
           (let* ( [num (real-part number-or-string)]
                   [real (if digits (+ 0.0 num) num)]
                   [imag (imag-part number-or-string)]
                 )
             (cond
               [(not (zero? imag))
                (string-grow
                 (string-append (format-fixed real 0 digits)
                                (if (negative? imag) "" "+")
                                (format-fixed imag 0 digits)
                                "i")
                 width
                 #\space)
                ]
               [digits
                (let* ( [num-str   (number->string (if (rational? real)
                                                       (+ 0.0 real)
                                                       real))]
                        [dot-index (string-index  num-str #\.)]
                        [exp-index (string-index  num-str #\e)]
                        [length    (string-length num-str)]
                        [pre-string
                         (cond
                           ((and exp-index (not dot-index))
                            (substring num-str 0 exp-index)
                            )
                           (dot-index
                            (substring num-str 0 dot-index)
                            )
                           (else
                            num-str))
                         ]
                        [exp-string
                         (if exp-index (substring num-str exp-index length) "")
                         ]
                        [frac-string
                         (let ( (dot-idx (if dot-index dot-index -1)) )
                           (if exp-index
                               (substring num-str (+ dot-idx 1) exp-index)
                               (substring num-str (+ dot-idx 1) length)))
                         ]
                        )
                  (string-grow
                   (if dot-index
                     (compose-with-digits digits
                                          pre-string
                                          frac-string
                                          exp-string)
                     (string-append pre-string exp-string))
                   width
                   #\space)
                  )]
               [else ;; no digits
                (string-grow (number->string real) width #\space)])
             )]
          [else
           (error 'format "~F requires a number or a string" number-or-string)])
        )
      

      (define documentation-string
        "(format [<port>] <format-string> [<arg>...]) -- <port> is #t, #f or an output-port\nOPTION  [MNEMONIC]      DESCRIPTION     -- Implementation Assumes ASCII Text Encoding\n~H      [Help]          output this text\n~A      [Any]           (display arg) for humans\n~S      [Slashified]    (write arg) for parsers\n~W      [WriteCircular] like ~s but outputs circular and recursive data structures\n~~      [tilde]         output a tilde\n~T      [Tab]           output a tab character\n~%      [Newline]       output a newline character\n~&      [Freshline]     output a newline character if the previous output was not a newline\n~D      [Decimal]       the arg is a number which is output in decimal radix\n~X      [heXadecimal]   the arg is a number which is output in hexdecimal radix\n~O      [Octal]         the arg is a number which is output in octal radix\n~B      [Binary]        the arg is a number which is output in binary radix\n~w,dF   [Fixed]         the arg is a string or number which has width w and d digits after the decimal\n~C      [Character]     charater arg is output by write-char\n~_      [Space]         a single space character is output\n~Y      [Yuppify]       the list arg is pretty-printed to the output\n~?      [Indirection]   recursive format: next 2 args are format-string and list of arguments\n~K      [Indirection]   same as ~?\n"
        )
      
      (define (require-an-arg args)
        (when (null? args)
          (problem "too few arguments"))
        )
      
      (define (format-help p format-strg arglist)
        
        (letrec (
                 [length-of-format-string (string-length format-strg)]
                 
                 [anychar-dispatch       
                  (lambda (pos arglist last-was-newline) 
                    (if (>= pos length-of-format-string) 
                      arglist ; return unused args 
                      (let ( [char (string-ref format-strg pos)] ) 
                        (cond            
                          [(eqv? char #\~)   
                           (tilde-dispatch (+ pos 1) arglist last-was-newline)]
                          [else                   
                           (write-char char p)     
                           (anychar-dispatch (+ pos 1) arglist #f)        
                           ])             
                        )))     
                  ] ; end anychar-dispatch
                 
                 [has-newline?
                  (lambda (whatever last-was-newline)
                    (or (eqv? whatever #\linefeed)
                        (and (string? whatever)
                             (let ( [len (string-length whatever)] )
                               (if (zero? len)
                                 last-was-newline
                                 (eqv? #\linefeed (string-ref whatever (- len 1)))))))
                    )] ; end has-newline?
                 
                 [tilde-dispatch          
                  (lambda (pos arglist last-was-newline)     
                    (cond           
                      ((>= pos length-of-format-string)   
                       (write-char #\~ p) ; tilde at end of string is just output
                       arglist ; return unused args
                       )     
                      (else      
                       (case (char-upcase (string-ref format-strg pos)) 
                         ((#\A)       ; Any -- for humans
                          (require-an-arg arglist)
                          (let ( [whatever (car arglist)] )
                            (display whatever p)
                            (anychar-dispatch (+ pos 1) 
                                              (cdr arglist) 
                                              (has-newline? whatever last-was-newline))
                            ))
                         ((#\S)       ; Slashified -- for parsers
                          (require-an-arg arglist)
                          (let ( [whatever (car arglist)] )
                            (write whatever p)     
                            (anychar-dispatch (+ pos 1) 
                                              (cdr arglist) 
                                              (has-newline? whatever last-was-newline)) 
                            ))
                         ((#\W)
                          (require-an-arg arglist)
                          (let ( [whatever (car arglist)] )
                            (write-with-shared-structure whatever p)  ;; srfi-38
                            (anychar-dispatch (+ pos 1) 
                                              (cdr arglist) 
                                              (has-newline? whatever last-was-newline))
                            ))                           
                         ((#\D)       ; Decimal
                          (require-an-arg arglist)
                          (display (number->string (car arglist) 10) p)  
                          (anychar-dispatch (+ pos 1) (cdr arglist) #f)  
                          )            
                         ((#\X)       ; HeXadecimal
                          (require-an-arg arglist)
                          (display (number->string (car arglist) 16) p)
                          (anychar-dispatch (+ pos 1) (cdr arglist) #f)  
                          )             
                         ((#\O)       ; Octal
                          (require-an-arg arglist)
                          (display (number->string (car arglist)  8) p) 
                          (anychar-dispatch (+ pos 1) (cdr arglist) #f) 
                          )       
                         ((#\B)       ; Binary
                          (require-an-arg arglist)
                          (display (number->string (car arglist)  2) p)
                          (anychar-dispatch (+ pos 1) (cdr arglist) #f) 
                          )           
                         ((#\C)       ; Character
                          (require-an-arg arglist)
                          (write-char (car arglist) p) 
                          (anychar-dispatch (+ pos 1)
                                            (cdr arglist)
                                            (eqv? (car arglist) #\linefeed))  
                          )          
                         ((#\~)       ; Tilde  
                          (write-char #\~ p)   
                          (anychar-dispatch (+ pos 1) arglist #f) 
                          )            
                         ((#\%)       ; Newline   
                          (newline p) 
                          (anychar-dispatch (+ pos 1) arglist #t) 
                          )
                         ((#\&)      ; Freshline
                          (if (not last-was-newline) ;; (unless last-was-newline ..
                            (newline p))
                          (anychar-dispatch (+ pos 1) arglist #t)
                          )
                         ((#\_)       ; Space 
                          (write-char #\space p)   
                          (anychar-dispatch (+ pos 1) arglist #f)
                          )             
                         ((#\T)       ; Tab -- IMPLEMENTATION DEPENDENT ENCODING    
                          (write-char ascii-tab p)          
                          (anychar-dispatch (+ pos 1) arglist #f)     
                          )             
                         ((#\Y)       ; Pretty-print
                          (pretty-print (car arglist) p)
                          (anychar-dispatch (+ pos 1) (cdr arglist) #f)
                          )              
                         ((#\F)
                          (require-an-arg arglist)
                          (display (format-fixed (car arglist) 0 #f) p)
                          (anychar-dispatch (+ pos 1) (cdr arglist) #f)
                          )
                         ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
                          ;; gather "~w[,d]F" w and d digits
                          (let loop ( [index (+ pos 1)]
                                      [w-digits (list (string-ref format-strg pos))]
                                      [d-digits '()]
                                      [in-width? #t]
                                      )
                            (if (>= index length-of-format-string)
                              (problem "improper numeric format directive" format-strg)
                              (let ( [next-char (string-ref format-strg index)] )
                                (cond
                                  [(char-numeric? next-char)
                                   (if in-width?
                                     (loop (+ index 1)
                                           (cons next-char w-digits)
                                           d-digits
                                           in-width?)
                                     (loop (+ index 1)
                                           w-digits
                                           (cons next-char d-digits)
                                           in-width?))
                                   ]
                                  [(char=? (char-upcase next-char) #\F)
                                   (let ( [width
                                           (string->number
                                            (list->string
                                             (reverse w-digits)))
                                           ]
                                          [digits
                                           (if (zero? (length d-digits))
                                             #f
                                             (string->number
                                              (list->string (reverse d-digits))))]
                                          )
                                     (display
                                      (format-fixed (car arglist) width digits)
                                      p)
                                     (anychar-dispatch (+ index 1) (cdr arglist) #f))
                                   ]
                                  [(char=? next-char #\,)
                                   (if in-width?
                                     (loop (+ index 1)
                                           w-digits
                                           d-digits
                                           #f)
                                     (problem "too many commas in directive" format-strg))
                                   ]
                                  [else
                                   (problem "~w,dF directive ill-formed" format-strg)])))
                            ))
                         ((#\? #\K)       ; indirection -- take next arg as format string
                          (cond           ;  and following arg as list of format args
                            ((< (length arglist) 2)
                             (problem "less arguments than specified for ~?" arglist)
                             )
                            ((not (string? (car arglist)))
                             (problem "~? requires a string" (car arglist))
                             )
                            (else
                             (format-help p (car arglist) (cadr arglist))
                             (anychar-dispatch (+ pos 1) (cddr arglist) #f)
                             )))
                         ((#\H)      ; Help
                          (display documentation-string p)
                          (anychar-dispatch (+ pos 1) arglist #t)
                          )
                         (else                
                          (problem "unknown tilde escape" (string-ref format-strg pos)))
                         )))
                    )] ; end tilde-dispatch   
                 ) ; end letrec            
          
          ; format-help body
          (anychar-dispatch 0 arglist #f) 
          )) ; end format-help    
      
      ; _format body
      (let ( [unused-args (format-help port format-string args)] )
        (if (not (null? unused-args))
          (problem "unused arguments" unused-args)
          (return-value port))))
    
    ; format body
    (if (string? arg0)
      (_format (open-output-string) arg0 arg* get-output-string)
      (if (null? arg*)
        (problem "too few arguments" (list arg0))
        (let ([port (cond [(eq? arg0 #f) (open-output-string)]
                          [(eq? arg0 #t) (current-output-port)]
                          [(output-port? arg0) arg0]
                          [else (problem "bad output-port argument" arg0)])]
              [arg1 (car arg*)])
          (if (string? arg1)
            (_format port arg1 (cdr arg*) (if arg0 (lambda (ignore) (values)) get-output-string))
            (problem "not a string" arg1)))))) 
)