;;;
;;; Time-stamp: <06/02/05 20:40:10 noel>
;;;
;;; Copyright (C) 2005 by Noel Welsh.
;;;

;;; This library 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 library 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 for more details.

;;; You should have received a copy of the GNU Lesser
;;; General Public License along with this library; if not,
;;; write to the Free Software Foundation, Inc., 59 Temple
;;; Place, Suite 330, Boston, MA 02111-1307 USA

;;; Author: Noel Welsh <noelwelsh@yahoo.com>
;;
;;
;; Commentary:
(module file mzscheme

  (require
   (lib "file.ss")
   (lib "plt-match.ss")
   (lib "string.ss" "srfi" "13"))

  (provide 
   (all-defined)
   )
  
  ;; make-directory-tree : (tree-of string) -> void
  (define (make-directory-tree tree)
    (define (tree-fold seed tree)
      (define (list->path head rest)
        (apply build-path (reverse (cons head rest))))
      (match tree
        [(? string? here)
         (make-directory* (list->path here seed))]
        [(list) (void)]
        [`(,(? string? head) (,children ...) . ,rest)
         (make-directory* (list->path head seed))
         (tree-fold (cons head seed) children)
         (tree-fold seed rest)]
        [`(,(? string? here) . ,rest)
         (make-directory* (list->path here seed))
         (tree-fold seed rest)]))
    (tree-fold null tree))
  
  ;; make-non-conflicting-path : path string -> path
  ;;
  ;; The path version of make-non-conflicting-filename, explained
  ;; below:
  (define (make-non-conflicting-path path filename)
    (build-path path (make-non-conflicting-filename path filename)))
  
  ;; make-non-conflicting-path : path string -> string
  ;;
  ;; Searches the specified path for any files whose name might conflict
  ;; with the suggested filename. If conflicting files are found, a
  ;; non-conflicting variant of filename is returned.
  ;;
  ;; If no conflicting files are found, the filename is returned untouched.
  ;;
  ;; Non-conflicting names are generated in a nice, friendly, Windows-esque
  ;; kind of way, where a digit is appended to the end of the stem of the
  ;; file. There are a few subtleties to this: examples follow:
  ;;
  ;;   my-file.txt becomes:
  ;;
  ;;     my-file1.txt if my-file.txt exists
  ;;     my-file2.txt if my-file.txt and my-file1.txt exist
  ;;
  ;;   test-file becomes:
  ;;
  ;;     test-file1 if test-file exists
  ;;
  ;;   my-file5.txt becomes:
  ;;
  ;;     my-file6.txt if my-file5.txt exists
  ;;
  ;;   my-file1.blah.txt becomes:
  ;;
  ;;     my-file1.blah1.txt if my-file1.blah.txt exists
  (define (make-non-conflicting-filename path filename)
    ;; stem->stem-and-index : string -> (values string integer)
    ;;
    ;; Strips trailing digits off a string and returns them as a number.
    ;;
    ;; For example:
    ;;     "abc123" => (values "abc" 123)
    ;;     "abc" =? (values "abc" 1)
    (define (stem->stem-and-index stem)
      (let loop ([stem stem] [index-string ""])
        (if (char-numeric? (string-ref stem (sub1 (string-length stem))))
            (loop (string-drop-right stem 1) 
                  (string-append index-string (string-take-right stem 1)))
            (values 
             stem
             (if (= (string-length index-string) 0)
                 1
                 (string->number index-string))))))
    (if (file-exists? (build-path path filename))
        ; Split the filename into a stem and an extension
        (let* ([pos (string-index-right filename #\.)]
               [stem (if pos (string-take filename pos) filename)]
               [extension (if pos (string-drop filename pos) "")])
          ; Find a non-conflicting filename and return it
          (let-values ([(stem index) 
                        (stem->stem-and-index stem)])
            (let loop ([index index])
              (let ([filename 
                     (string-append 
                      stem
                      (number->string index) 
                      extension)])
                (if (file-exists? (build-path path filename))
                    (loop (add1 index))
                    filename)))))
        filename))

  )