;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Clean up build artifacts.
;;;
;;; Copyright (c) 2018-2022, Evan Hanson
;;;
;;; See LICENSE for details.
;;;

;;
;; The `chicken-clean` program deletes egg build artifacts.
;;
;; A simple set of file patterns is used to determine what should be
;; deleted. This includes compiled programs, binary objects (`o`, `obj`,
;; `so`, `dll`), and files generated by the CHICKEN toolchain (`build.sh`,
;; `install.sh`, `import.scm`, `inline`, `profile`, `types`).
;;
;; When run with the `-interactive` flag, a confirmation prompt will be
;; displayed before any files are deleted.
;;
(declare
  (module (chicken-clean))
  (import (beaker egg info)
          (beaker interactive)
          (chicken condition)
          (chicken errno)
          (chicken file)
          (chicken irregex)
          (chicken pathname)
          (chicken process-context)
          (chicken sort)
          (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))))

(define (disposable-file? path)
  (and (not (directory-exists? path))
       (or (member (normalize-pathname path)
                   (local-egg-build-artifacts))
           (irregex-match
            `(or ,(glob->sre "*.o")
                 ,(glob->sre "*.obj")
                 ,(glob->sre "*.so")
                 ,(glob->sre "*.dll")
                 ,(glob->sre "*.build.sh")
                 ,(glob->sre "*.build.target.sh")
                 ,(glob->sre "*.install.sh")
                 ,(glob->sre "*.install.target.sh")
                 ,(glob->sre "*.import.scm")
                 ,(glob->sre "*.inline")
                 ,(glob->sre "*.link")
                 ,(glob->sre "*.profile")
                 ,(glob->sre "*.types"))
            (pathname-strip-directory path)))))

(define (disposable-directory? path)
  (and (directory-exists? path)
       ((flip every)
        (directory path)
        (lambda (p)
          (let ((p* (make-pathname path p)))
            (or (disposable-file? p*)
                (disposable-directory? p*)))))))

(define (remove-file path)
  (message 1 (conc "Removing " path))
  (delete-file* path))

(define (remove-directory path)
  (message 1 (conc "Removing " path))
  (condition-case (delete-directory path)
    (e (i/o file)
       (unless (or (= (errno) errno/noent)
                   (= (errno) errno/notempty))
         (signal e)))))

(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] [<path> ...]"))
  (exit status))

(define (main)
  (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))
  (else))