;;;; directory-utils.scm
;;;; Kon Lovett, Aug '10

(module directory-utils

  (;export
    pathname? check-pathname error-pathname
    filename? check-filename error-filename
    dot-pathname? dot-filename?
    #;directory? check-directory error-directory
    directory-fold
    push-directory
    pop-directory
    pop-toplevel-directory
    create-directory/parents
    create-pathname-directory
    make-program-filename
    make-shell-filename
    file-exists/directory?
    find-file-pathnames
    find-program-pathnames
    which-command-pathnames
    which-command-pathname
    remove-dotfiles)

  (import
    scheme
    chicken
    (only data-structures
      string-split)
    (only files
      make-pathname
      pathname-directory pathname-extension pathname-file
      decompose-pathname decompose-directory)
    (only posix
      directory directory? current-directory create-directory
      file-exists?)
    (only srfi-1
      first fold append! filter-map remove any)
    (only srfi-13
      string-null? string-prefix?)
    (only miscmacros
      until)
    (only list-utils
      not-null? ensure-list)
    (only stack
      make-stack stack-push! stack-empty? stack-pop!)
    (only type-checks
      define-check+error-type
      check-procedure))

  (require-library
    data-structures srfi-1 srfi-13 files posix
    miscmacros list-utils stack type-checks)

;;; Helpers

(cond-expand
  (windows  (define-constant PATH-DELIMITER ";"))
  (else     (define-constant PATH-DELIMITER ":")))

(define (dot-prefix? str) (string-prefix? "." str))

(define (pathname-maybe? obj) (string? obj))

(define dot-directory (make-pathname "." #f))

;;;

;;

(define-check+error-type directory)

;; A null pathname or only extension is not a pathname, here at least

; detecting only an extension is impossible with string pathnames

(define (pathname? obj)
  (and (pathname-maybe? obj)
       (let-values (((dir fil ext) (decompose-pathname obj)))
         (or dir fil))) )

(define-check+error-type pathname)

;; Just a filename, no directory

(define (filename? obj)
  (and (pathname-maybe? obj)
       (let-values (((dir fil ext) (decompose-pathname obj)))
         (and (not dir) fil))) )

(define-check+error-type filename)

;; Any pathname component is a dot-filename?

(define (dot-pathname? obj)
  (and (pathname-maybe? obj)
       (let-values (((dir fil ext) (decompose-pathname obj)))
         (or (dot-prefix? fil)
             (let-values (((org dir elts) (decompose-directory dir)))
               (and elts
                    (any dot-prefix? elts)))))) )

;;

(define (dot-filename? obj)
  (and (filename? obj)
       (dot-prefix? obj)) )

;; Remove dot files from a directory list

(define (remove-dotfiles files)
	(remove (lambda (pn) (dot-filename? (pathname-file pn))) files) )

;;

(define (directory-fold func #!optional (ident '()) (dir dot-directory) #!key (dotfiles? #f))
  (fold
    (check-procedure 'directory-fold func)
    ident
    (directory (check-directory 'directory-fold dir) dotfiles?)) )

;; Directory Stack

(define push-directory)
(define pop-directory)
(define pop-toplevel-directory)

(let ((+directory-stack+ (make-stack)))

  (set! push-directory
    (lambda (dir)
      (stack-push! +directory-stack+ (current-directory))
      ; Don't cd unless necessary
      (when (and dir
                 (not (or (string-null? dir)
                          (string=? dot-directory (make-pathname dir #f)))))
        (current-directory dir) ) ) )

  (set! pop-directory
    (lambda ()
      (unless (stack-empty? +directory-stack+)
        (current-directory (stack-pop! +directory-stack+)) ) ) )

  (set! pop-toplevel-directory
    (lambda ()
      (until (stack-empty? +directory-stack+)
        (pop-directory) ) ) ) )

;; Ensure the directory exists.

#; ;Not Needed Anymore
(define (create-directory/parents dir)
  (let loop ((dir dir))
    (when (and dir (not (directory? dir)))
      (loop (pathname-directory dir))
      (create-directory dir) ) ) )

(define (create-directory/parents dir)
  (create-directory (check-pathname 'create-directory/parents dir) #t) )

;; Ensure the directory for the specified path exists.

(define (create-pathname-directory pathname)
 (check-pathname 'create-pathname-directorys pathname)
 (create-directory/parents (pathname-directory pathname)) )

;; Platform specific program filename.

(define (make-program-filename bn)
  (cond-expand
    (windows
      (if (pathname-extension bn) bn
        (make-pathname #f bn ".exe")))
    (else
      bn)) )

(define (make-shell-filename bn)
  (cond-expand
    (windows
      (if (pathname-extension bn) bn
        (make-pathname #f bn ".bat")))
    (else
      (if (pathname-extension bn) bn
        (make-pathname #f bn ".sh")))) )

;; Pathname if file exists in directory.

(define (file-exists/directory? fil #!optional dir)
  (let ((path (make-pathname dir fil)))
    (and (file-exists? path)
         path) ) )

;; List of all found pathnames.

(define (find-file-pathnames/directory fil dir)
  (filter-map (cut file-exists/directory? fil <>) (ensure-list dir)) )

(define (*find-file-pathnames fil dirs)
  (let loop ((dirs dirs)
             (paths '()))
    (if (null? dirs) (not-null? paths)
      (loop
        (cdr dirs)
        (append!
          paths
          (find-file-pathnames/directory fil (car dirs)))) ) ) )

(define (find-file-pathnames fil . dirs)
  (*find-file-pathnames fil dirs) )

;; All found program pathname in directories.

(define (find-program-pathnames cmd . dirs)
  (cond-expand
    (windows
      (if (pathname-extension cmd) (*find-file-pathnames cmd dirs)
        (let ((pfs (*find-file-pathnames (make-program-filename cmd) dirs))
              (sfs (*find-file-pathnames (make-shell-filename cmd) dirs)))
          (not-null? (append! (or pfs '()) (or sfs '()))) ) ) )
    (else
      (*find-file-pathnames (make-program-filename cmd) dirs) ) ) )

;; All found program pathname in path.

(define (which-command-pathnames cmd #!optional (varnam "PATH"))
  (and-let* ((path (get-environment-variable varnam)))
    (find-program-pathnames cmd (string-split path PATH-DELIMITER)) ) )

;; First found program pathname in path.

(define (which-command-pathname cmd #!optional (varnam "PATH"))
  (and-let* ((ps (which-command-pathnames cmd varnam)))
    (first ps) ) )

) ;directory-utils