#lang scheme
(require planet/util
scheme/system
)
(define (ok) (printf "OK\n"))
(define (regexp-find-files pattern [type 'both])
(find-files
(λ(f)(and (or (and (equal? type 'dir) (directory-exists? f))
(and (equal? type 'file) (file-exists? f))
(equal? type 'both))
(regexp-match
pattern
(path->string f))
f))
(build-path ".")
))
(define (file-pattern->regexp pattern)
(let* ([pattern (string-append "^" pattern "$")]
[pattern (regexp-replace* "\\." pattern "\\\\.")]
[pattern (regexp-replace* "\\*" pattern ".*")]
[pattern (regexp-replace* "/" pattern "\\\\\\\\")]
)
pattern
))
(define (pattern-find-files pat [type 'both])
(regexp-find-files
(file-pattern->regexp pat)
type
))
(define (safe-delete paths)
(printf "Are you sure you want to delete these paths (yes/no)?\n")
(pretty-print paths)
(newline)
(let ([res (read-line)])
(when (equal? res "yes")
(printf "Deleting...")
(map delete-directory/files paths)
(ok)
)))
(define (bak-files)
(pattern-find-files "*.bak" 'file))
(define (svn-dirs)
(pattern-find-files "*/.svn" 'dir))
(define (compiled-dirs)
(pattern-find-files "*/compiled" 'dir))
(define (test-dirs)
(pattern-find-files "*/test*" 'dir))
(define (clean-project)
(safe-delete (compiled-dirs)))
(define (strip-project)
(clean-project) (safe-delete (bak-files))
(safe-delete (test-dirs))
(safe-delete (svn-dirs))
)
(define (make-plt)
(safe-delete (bak-files))
(make-planet-archive
(current-directory)
(build-path (current-directory) 'up
"mred-designer.plt")
))