~evhan/beaker

367b34d3ce173e1b5530e11dfe1ea9f5d4336164 — Evan Hanson 1 year, 7 months ago d5e6740 0.0.18
Allow passing specific paths to chicken-clean
1 files changed, 43 insertions(+), 26 deletions(-)

M chicken-clean.scm
M chicken-clean.scm => chicken-clean.scm +43 -26
@@ 32,6 32,9 @@
          (chicken string)
          (srfi 1)))

(define (list-if test value)
  (if (test value) (list value) (list)))

(define (local-egg-build-artifacts)
  (let ((egg-files (glob "*.egg" "chicken/*.egg")))
    (map symbol->string (append-map egg-programs egg-files))))


@@ 56,14 59,6 @@
                 ,(glob->sre "*.types"))
            (pathname-strip-directory path)))))

(define (file-removal-summary paths)
  (conc "The following files will be removed:"
        #\newline
        #\newline
        (foldl (lambda (s p) (conc s "  " p #\newline)) "" paths)
        #\newline
        "Continue?"))

(define (disposable-directory? path)
  (and (directory-exists? path)
       ((flip every)


@@ 85,29 80,51 @@
                   (= (errno) errno/notempty))
         (signal e)))))

(define (clean-working-directory)
  (let* ((files       (find-files "." test: disposable-file?))
         (directories (find-files "." test: disposable-directory?))
         (sorted      (sort (append files directories) string<?)))
    (when (and (pair? sorted) (prompt (file-removal-summary sorted)))
      (for-each remove-file files)
      (for-each remove-directory directories))))
(define (file-removal-summary paths)
  (conc "The following files will be removed:"
        #\newline
        #\newline
        (foldl (lambda (s p) (conc s "  " p #\newline)) "" paths)
        #\newline
        "Continue?"))

(define (collect-disposable-files path)
  (cond ((disposable-file? path) (list path))
        ((directory-exists? path)
         (append (list-if disposable-directory? path)
                 (find-files path test: disposable-file?)
                 (find-files path test: disposable-directory?)))
        (else (list))))

(define (clean-paths paths)
  (let* ((disposable (append-map collect-disposable-files paths))
         (sorted     (sort disposable string<?)))
    (receive (directories files) (partition directory-exists? sorted)
      (when (and (pair? sorted) (prompt (file-removal-summary sorted)))
        (for-each remove-file files)
        (for-each remove-directory directories)))))

(define (usage status)
  (message 0 (conc "Usage: " (pathname-file (program-name)) " [-interactive | -quiet | -verbose]"))
  (message 0 (conc "Usage: " (pathname-file (program-name)) " [-interactive | -quiet | -verbose] [<path> ...]"))
  (exit status))

(define (main)
  ((flip for-each)
   (command-line-arguments)
   (lambda (flag)
     (case (string->symbol flag)
       ((-quiet) (verbosity (sub1 (verbosity))))
       ((-verbose) (verbosity (add1 (verbosity))))
       ((-interactive) (interactive #t))
       ((-h -help) (usage 0))
       (else (usage 1)))))
  (clean-working-directory))
  (let ((paths '()))
    ((flip for-each)
     (command-line-arguments)
     (lambda (flag)
       (case (string->symbol flag)
         ((-quiet) (verbosity (sub1 (verbosity))))
         ((-verbose) (verbosity (add1 (verbosity))))
         ((-interactive) (interactive #t))
         ((-h -help) (usage 0))
         (else (set! paths (cons flag paths))))))
    (if (any (lambda (p) (irregex-search "^-" p)) paths)
        (usage 1)
        (clean-paths
         (if (null? paths)
             (list ".")
             (reverse paths))))))

(cond-expand
  (compiling (main))