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

;; Issues
;;
;; - See scattered 'FIXME' entries.

(module directory-utils

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

(import scheme chicken)
(use
  (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)
  (only srfi-1
    first fold append! filter-map remove any)
  (only srfi-13
    string-null? string-prefix?)
  (only miscmacros
    define-parameter until)
  (only list-utils
    not-null? ensure-list)
  (only stack
    make-stack stack?
    stack-empty?
    stack-push! stack-pop!)
  (only type-checks
    define-check+error-type
    check-procedure)
  typed-define)

;;; Helpers

;;

(define-type stack (struct stack))

(define-type filename string)
(define-type extension string)
(define-type basename string)
(define-type pathname string)

;;

(define (->boolean obj)
  (and obj #t) )

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

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

;;

;no . or .. since directoryname
(define: (dot-filename-prefix? (str filename)) -> boolean
  (and
    (string-prefix? "." str)
    ;FIXME unix-centric
    (not (or (string=? "." str) (string=? ".." str)))) )

;;;

;;

(define-check+error-type directory)

;NOTE do not type these as 'predicate'
;ex: (: filename? (* -> boolean : filename))
;since the compiler will treat a literal ".." as
;meeting the criteria at compile time!

;; 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 *)) --> boolean
  (and
    (string? obj)
    (receive (dir fil ext) (decompose-pathname obj)
      (->boolean (or dir fil)))) )

(define-check+error-type pathname)

;; Just a filename, no directory

(define: (filename? (obj *)) --> boolean
  (and
    (string? obj)
    (receive (dir fil ext) (decompose-pathname obj)
      (not dir))) )

(define-check+error-type filename)

;;

(define: (dot-filename? (obj *)) --> boolean
  (and
    (filename? obj)
    (dot-filename-prefix? obj)) )

;; Is any pathname component is a dot-filename?

(define: (dot-pathname? (obj *)) --> boolean
  (and
    (string? obj)
    (let-values (
      ((dir fil ext) (decompose-pathname obj)) )
      (or
        (dot-filename-prefix? fil)
        (let-values (
          ((org dir elts) (decompose-directory dir)) )
          (and
            elts
            (any dot-filename-prefix? elts)))))) )

;; Remove dot files from a directory list

(define: (remove-dotfiles (files (list-of pathname))) -> (list-of pathname)
	(remove
	  (lambda (pn)
	    (dot-filename? (pathname-file pn)) )
	  files) )

;;

;FIXME need a routine that provides filename and stat info to the fold func.
;The stat info should include platform specific info as well: the Windows Hidden
;attribute, the MacOS X birthtime, etc.

(define: (directory-fold (func procedure) (ident *) (dir pathname) . (opts (list pathname))) -> *
  (check-procedure 'directory-fold func)
  (let* (
    (dotfiles? (get-keyword #:dotfiles? opts (lambda () #f)))
    (dir (directory (check-directory 'directory-fold dir) dotfiles?)) )
    (fold func ident dir) ) )

;; Directory Stack

(: directory-utility-stack (#!optional stack -> stack))
;
(define-parameter directory-utility-stack (make-stack)
  (lambda (x)
    (if (stack? x)
      x
      (begin
        (warning '+directory-stack+ "not a stack")
        (directory-utility-stack)))))

(define: (ignored-directory? (dir pathname)) --> boolean
  (or
    (string-null? dir)
    (string=? +dot-directory+ (make-pathname dir #f))) )

(define: (push-directory (dir (or boolean pathname)))
  (stack-push! (directory-utility-stack) (current-directory))
  ;don't cd unless necessary
  (when (and dir (not (ignored-directory? dir)))
    (current-directory dir) ) )

(define: (pop-directory)
  (unless (stack-empty? (directory-utility-stack))
    (current-directory (stack-pop! (directory-utility-stack))) ) )

(define: (pop-toplevel-directory)
  (until (stack-empty? (directory-utility-stack))
    (pop-directory) ) )

;; Ensure the directory for the specified path exists.

(define: (create-pathname-directory (pn pathname)) -> boolean
  (->boolean
    (create-directory
      (pathname-directory (check-pathname 'create-pathname-directory pn))
      #t)) )

;; Platform specific program filename.

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

(define: (make-shell-filename (bn basename)) -> filename
  (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-in-directory? (fil filename) . (opts (list-of pathname))) -> (or boolean pathname)
  (let* (
    (dir (optional opts #f))
    (path (make-pathname dir fil)) )
    (and (file-exists? path) path) ) )

;; List of all found pathnames.

(define: (find-file-pathnames-in-directory (fil filename) (dir pathname)) -> (list-of pathname)
  (filter-map
    (cut file-exists-in-directory? fil <>)
    (ensure-list dir)) )

(define: (*find-file-pathnames (fil filename) (dirs (list-of pathname))) -> (or boolean (list-of pathname))
  (let loop ((dirs dirs) (paths '()))
    (if (null? dirs)
      (not-null? paths)
      (loop
        (cdr dirs)
        (append!
          paths
          (find-file-pathnames-in-directory fil (car dirs))))) ) )

(define: (find-file-pathnames (fil filename) . (dirs (list-of pathname))) -> (or boolean (list-of pathname))
  (*find-file-pathnames fil dirs) )

;; All found program pathname in directories.

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

;; All found program pathname in path.

(define: (which-command-pathnames (cmd filename) . (opts (list string))) -> (or boolean list)
  (let (
    (varnam (optional opts "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 filename) . (opts (list string))) -> (or boolean list)
  (let (
    (varnam (optional opts "PATH")) )
    (and-let* (
      (ps (which-command-pathnames cmd varnam)) )
      (first ps) ) ) )

;;

;; Ensure the directory exists.

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

#; ;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) ) ) )

(: file-exists/directory? (deprecated file-exists-in-directory?))
(define file-exists/directory? file-exists-in-directory?)

) ;directory-utils