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

;; Issues
;;
;; - Need a routine that provides filename and stat info to the fold func.
;; stat info: Posix + platform specific:
;; Windows Hidden attribute ...
;; macOS birthtime ...
;;
;; - Windows support is bit of a joke.

(module directory-utils

(;export
  pathname? check-pathname error-pathname
  filename? check-filename error-filename
  dirname? check-dirname error-dirname
  ;existence check documented
  check-directory error-directory
  ;
  dot-filename-prefix?
  dot-pathname? dot-filename?
  remove-dotfiles
  ;
  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)

(import scheme utf8)
(import (chicken process-context))
(import (chicken base))
(import (chicken type))
;existence check documented
(import (only (chicken file posix) directory?))
(import (only (chicken keyword) get-keyword))
(import (only (chicken process-context) current-directory change-directory))
(import (only (chicken string) string-split))
(import (only (chicken pathname)
  make-pathname
  pathname-directory pathname-extension pathname-file
  decompose-pathname decompose-directory))
(import (only (chicken file) file-exists? directory create-directory))
(import (only (srfi 1) concatenate fold append! filter-map remove any))
(import (only utf8-srfi-13 string-null? string-prefix?))
(import (only miscmacros until))
(import (only moremacros define-warning-parameter))
(import (only list-utils not-null? ensure-list))
(import (only stack make-stack stack? stack-empty? stack-push! stack-pop!))
(import (only type-errors warning-argument-type)) ;BUG for define-warning-parameter
(import (only type-checks-basic define-check+error-type))
(import (only (check-errors sys) check-procedure))

(define-type stack (struct stack#stack))

(define-type optional-list (or false list))

(include-relative "directory-utils.types")

(: dot-filename-prefix? (filename -> boolean))
;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!
(: dirname? (* --> boolean))
(: check-dirname (* * #!optional * -> dirname))
(: error-dirname (* * #!optional * -> void))
(: check-directory (* * #!optional * -> dirname))
(: error-directory (* * #!optional * -> void))
(: pathname? (* --> boolean))
(: check-pathname (* * #!optional * -> pathname))
(: error-pathname (* * #!optional * -> void))
(: filename? (* --> boolean))
(: check-filename (* * #!optional * -> filename))
(: error-filename (* * #!optional * -> void))
(: dot-filename? (* --> boolean))
(: dot-pathname? (* --> boolean))
(: remove-dotfiles ((list-of pathname) --> (list-of pathname)))
#; ;FIXME while this is accurate "cons '()" is the downfall
(: directory-fold ((pathname 'a -> 'a) 'a pathname #!key (dotfiles? boolean) -> 'a))
(: directory-fold (procedure * pathname #!key (dotfiles? boolean) -> *))
(: directory-utility-stack (#!optional stack -> stack))
(: ignored-directory? (pathname --> boolean))
(: push-directory ((or false pathname) #!optional stack -> void))
(: pop-directory (#!optional stack -> void))
(: pop-toplevel-directory (#!optional stack -> void))
(: create-pathname-directory (pathname -> boolean))
(: make-program-filename (basename --> filename))
(: make-shell-filename (basename -> filename))
(: file-exists-in-directory? (filename #!rest (list pathname) -> (or false pathname)))
(: find-file-pathnames-in-directory (filename pathname -> (list-of pathname)))
(: find-file-pathnames (filename #!rest -> (or false (list-of pathname))))
(: find-program-pathnames (filename #!rest (list-of pathname) -> optional-list))
(: which-command-pathnames (filename #!rest (list string) -> optional-list))
(: which-command-pathname (filename #!rest (list string) -> optional-list))

(: *find-file-pathnames (filename (list-of pathname) -> (or false (list-of pathname))))
(: *find-program-pathnames (filename (list-of pathname) -> (or false (list-of pathname))))

;;

(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)
  (and (string-prefix? "." str)
       #+unix
       (not (or (string=? "." str) (string=? ".." str)))) )

;;

(define (ensure-list-of args)
  ;ensure-list is a macro!
  (concatenate (map (lambda (x) (ensure-list x)) args)) )

;;

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

(define (dirname? obj)
  (and (string? obj)
       (receive (dir fil ext) (decompose-pathname obj)
         (->boolean dir))) )

(define-check+error-type dirname)
;existence check documented
(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 (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)
  (and (string? obj)
       (receive (dir fil ext) (decompose-pathname obj)
         (and (not dir) fil))) )

(define-check+error-type filename)

;;

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

;; Any pathname component a dot-filename?

(define (dot-pathname? obj)
  (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)
  (remove (lambda (pn) (dot-filename? (pathname-file pn))) files) )

;;

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

;; Directory Stack

(define-warning-parameter directory-utility-stack (make-stack) stack)

;;

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

(define (push-directory dir #!optional (dirstack (directory-utility-stack)))
  (stack-push! dirstack (current-directory))
  ;don't cd unless necessary
  (when (and dir (not (ignored-directory? dir)))
    (change-directory dir) ) )

(define (pop-directory #!optional (dirstack (directory-utility-stack)))
  (unless (stack-empty? dirstack)
    (change-directory (stack-pop! dirstack)) ) )

(define (pop-toplevel-directory #!optional (dirstack (directory-utility-stack)))
  (until (stack-empty? dirstack)
    (pop-directory dirstack) ) )

;; Ensure the directory for the specified path exists.

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

;; 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-in-directory? fil . opts)
  (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 dir)
  (filter-map (cut file-exists-in-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-in-directory fil (car dirs))))) ) )

(define (find-file-pathnames fil . dirs)
  (*find-file-pathnames fil (ensure-list-of 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 ((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) ) ) )

(define (find-program-pathnames cmd . dirs)
  (*find-program-pathnames cmd (ensure-list-of dirs)) )

;; All found program pathname in path.

(define (which-command-pathnames cmd . opts)
  (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 . opts)
  (let ((varnam (optional opts "PATH")))
    (and-let* ((ps (which-command-pathnames cmd varnam))
               ((not (null? ps))) )
      (car ps) ) ) )

) ;directory-utils