#lang mzscheme

(require scheme/file
         scheme/match
         scheme/port
         srfi/13/string
         (planet "read.ss" ("ryanc" "scripting.plt" 1)))

(provide (all-defined))

;; make-directory-tree : (tree-of string) -> void
;;
;; Makes a tree of directories from a nested list specification:
;;
;;     <FOLDERS-SPEC> = (list <FOLDER-SPEC> ...)
;;     <FOLDER-SPEC>  = string <FOLDERS-SPEC>
;;
;; For example:
;;    
;;     '("top1"
;;        ("folder1"
;;         ("subfolder1a" "subfolder1b")
;;         "folder2"
;;         ("subfolder2a" "subfolder2b"))
;;       "top2"
;;        ("folder1"
;;         ("subfolder1a" "subfolder1b")
;;         "folder2"
;;         ("subfolder2a" "subfolder2b")))
(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-filename : 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))

;; read-file->string : (U path string) -> string
(define (read-file->string path)
  (let ([in  (open-input-file path)]
        [out (open-output-string)])
    (let loop ()
      (let ([buf (read-string 1024 in)])
        (unless (eof-object? buf)
          (display buf out)
          (loop))))
    (close-input-port in)
    (get-output-string out)))

;; concactenate-files : (U string path) (list-of (U string path)) -> void
(define (concatenate-files des src)
  (with-output-to-file des
    (lambda ()
      (copy-port (apply input-port-append
                        #t
                        (map open-input-file src))
                 (current-output-port)))))