;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Clean up build artifacts.
;;;
;;; Copyright (c) 2018-2019, 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 (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 "*.install.sh")
                 ,(glob->sre "*.import.scm")
                 ,(glob->sre "*.inline")
                 ,(glob->sre "*.link")
                 ,(glob->sre "*.profile")
                 ,(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)
        (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 (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 (usage status)
  (message 0 (conc "Usage: " (pathname-file (program-name)) " [-interactive | -quiet | -verbose]"))
  (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))

(cond-expand
  (compiling (main))
  (else))