;;; @Package     tabexpand.scm
;;; @Subtitle    Tab Character Expansion in Scheme
;;; @HomePage    http://www.neilvandyke.org/tabexpand-scm/
;;; @Author      Neil W. Van Dyke
;;; @AuthorEmail neil@@neilvandyke.org
;;; @Version     0.1
;;; @Date        9 May 2004

;; $Id: tabexpand.scm,v 1.5 2004/05/09 13:19:15 neil Exp $

;;; @legal
;;; Copyright @copyright{} 2004 Neil W. Van Dyke.  This program is Free
;;; 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 2.1 of the License, 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 the GNU Lesser
;;; General Public License [LGPL] for more details.
;;; @end legal

;;; @section Introduction

;;; There is no denying that ASCII tab characters are an archaic abomination
;;; [JWZ].  Savvy Emacs users might have noticed that the [Quack] option
;;; variable @code{quack-tabs-are-evil-p} defaults to true.  Note also that
;;; @code{quack-tidy} gladly slays any tab in sight, laughing maniacally as
;;; only the truly righteous can.  Sadly, not all strings in the universe are
;;; Scheme code subject to the wrath of Quack, therefore...
;;;
;;; This very simple Scheme library provides procedures for expanding tab
;;; characters.  It was written early one Sunday morning to complement the
;;; plethora of PLT-specific solutions being offered to the problem on the
;;; nascent Schematics cookbook Wiki.  Its source code is a bit verbose, but it
;;; tries not to generate much garbage, it supports non-zero starting columns,
;;; and it should work with any R5RS Scheme implementation that supports
;;; [SRFI-6].  (A future edition of this continuing epic might remove the
;;; dependency on SRFI-6, should we bother to benchmark and find that some
;;; implementations are not as efficient as we'd like.)
;;;
;;; At time of this writing, the author notes with no small amount of interest
;;; that the Internet domain name @code{tabexpand.com} has not yet been taken.

;;; @section Procedures

;;; Three procedures are provided.  Most applications will use the simple
;;; @code{tabexpand}.

;;; @defproc  tabexpand/stop/col str stop col
;;; @defprocx tabexpand/stop     str stop
;;; @defprocx tabexpand          str
;;;
;;; Yields a new string that is equivalent to string @var{str} except that any
;;; ASCII tab characters have been expanded to space characters.  @var{stop}, a
;;; positive integer defaulting to @code{8}, is used as the tabstop.
;;; @var{col}, a nonnegative integer defaulting to @code{0}, is the context
;;; starting column for the beginning of the string, with respect to which tabs
;;; positions should be calculated.  All characters other than tab are treated
;;; as if they were normal printable characters with no special effect on the
;;; column.

(define tabexpand/stop/col
  (letrec ((tab-char (integer->char 9))
           (tab-space-8-vector
            (vector ""
                    (make-string 1 #\space)
                    (make-string 2 #\space)
                    (make-string 3 #\space)
                    (make-string 4 #\space)
                    (make-string 5 #\space)
                    (make-string 6 #\space)
                    (make-string 7 #\space)
                    (make-string 8 #\space)))
           (tab-space-string
            (lambda (n)
              (if (<= 0 n 8)
                  (vector-ref tab-space-8-vector n)
                  (make-string n #\space)))))
    (lambda (str stop col)
      (let ((len (string-length str)))
        (let find-first-tab ((col col)
                             (i      0))
          (if (= i len)
              (string-copy str)
              (if (eqv? (string-ref str i) tab-char)
                  (let ((os (open-output-string)))
                    ;; Note: We could see whether iterating over the substring
                    ;; and calling write-char is faster than allocating a
                    ;; substring for a particular Scheme implementation.
                    (display (substring str 0 i) os)
                    (let expand-tab-and-find-next ((col col)
                                                   (i   i))
                      (let* ((spaces0 (- stop (modulo col stop)))
                             (spaces  (if (= spaces0 0) stop spaces0)))
                        (display (tab-space-string spaces) os)
                        (let find-next-tab ((col (+ col spaces))
                                            (i   (+ 1 i)))
                          (if (= i len)
                              (let ((result (get-output-string os)))
                                (close-output-port os)
                                result)
                              (let ((c (string-ref str i)))
                                (if (eqv? c tab-char)
                                    (expand-tab-and-find-next col i)
                                    (begin (write-char c os)
                                           (find-next-tab (+ 1 col)
                                                          (+ 1 i))))))))))
                  (find-first-tab (+ 1 col) (+ 1 i)))))))))

(define (tabexpand/stop str stop)
  (tabexpand/stop/col str stop 0))

(define (tabexpand str)
  (tabexpand/stop/col str 8 0))

;; TODO: Use a portable test suite tool, and add a comprehensive set of test
;;       cases.
;; 
;; (letrec ((test (lambda (input expected)
;;                  (write (cons 'tabexpand input))
;;                  (display " => ")
;;                  (let ((result (tabexpand input)))
;;                    (write result)
;;                    (if (equal? result expected)
;;                        (display " ; OK")
;;                        (begin (display " ; FAILED! ")
;;                               (write expected)))
;;                    (newline)))))
;;   (newline)
;;   ;;
;;   (test "\t"           "        ")
;;   (test "a\tb"         "a       b")
;;   (test "a\tbc"        "a       bc")
;;   ;;
;;   (test "a\t"          "a       ")
;;   (test "ab\t"         "ab      ")
;;   (test "abc\t"        "abc     ")
;;   (test "abcd\t"       "abcd    ")
;;   (test "abcde\t"      "abcde   ")
;;   (test "abcdef\t"     "abcdef  ")
;;   (test "abcdefg\t"    "abcdefg ")
;;   (test "abcdefgh\t"   "abcdefgh        ")
;;   (test "abcdefghi\t"  "abcdefghi       ")
;;   ;;
;;   (test "\t\tabcdefghi" "                abcdefghi")
;;   (test "\ta\tbcdefghi" "        a       bcdefghi")
;;   (test "\tab\tcdefghi" "        ab      cdefghi")
;;   (test "\tabc\tdefghi" "        abc     defghi")
;;   (test "\tabcd\tefghi" "        abcd    efghi")
;;   (test "\tabcde\tfghi" "        abcde   fghi")
;;   (test "\tabcdef\tghi" "        abcdef  ghi")
;;   (test "\tabcdefg\thi" "        abcdefg hi")
;;   (test "\tabcdefgh\ti" "        abcdefgh        i")
;;   ;;
;;   (test "abcdefghijklmnop" "abcdefghijklmnop")
;;   ;;
;;   (test "ab\tcd\tef\tg"   "ab      cd      ef      g")
;;   (test "ab\tcd\t\tef"    "ab      cd              ef")
;;   ;;
;;   (newline))

;;; @unnumberedsec History

;;; @table @asis
;;;
;;; @item Version 0.1 --- 9 May 2004
;;; Wrote.
;;;
;;; @end table

;;; @unnumberedsec References

;;; @table @asis
;;;
;;; @item [JWZ]
;;; Jamie Zawinski, ``Tabs versus Spaces: An Eternal Holy War,'' 2000.
;;; @uref{http://www.jwz.org/doc/tabs-vs-spaces.html}
;;;
;;; @item [LGPL]
;;; Free Software Foundation, ``GNU Lesser General Public License,'' Version
;;; 2.1, February 1999, 59 Temple Place, Suite 330, Boston, MA 02111-1307
;;; USA.  @uref{http://www.gnu.org/copyleft/lesser.html}
;;;
;;; @item [Quack]
;;; @uref{http://www.neilvandyke.org/quack/}
;;;
;;; @item [SRFI-6]
;;; William D. Clinger, ``Basic String Ports,'' SRFI 6, 1 July 1999.@*
;;; @uref{http://srfi.schemers.org/srfi-6/srfi-6.html}
;;;
;;; @end table