Exclude compiled and exclude optional exclude list.

main.rkt

@@ -9,6 +9,9 @@
 
 (provide zip-package)
 
+(define excluded-directory-names
+  '(".git" "compiled"))
+
 (define scribble-directory-names
   '("scribblings" "scribbles" "scrbl"))
 
@@ -18,18 +21,52 @@
 (define (path-component-strings path)
   (for/list ([part (in-list (explode-path path))]
              #:when (path? part))
-    (string-downcase (path-element->string part))))
+    (path-element->string part)))
 
 (define (string-in? value strings)
   (for/or ([candidate (in-list strings)])
     (string=? value candidate)))
 
-(define (excluded-path? path)
+(define (path-prefix? prefix components)
+  (and (<= (length prefix) (length components))
+       (equal? prefix (take components (length prefix)))))
+
+(define (relative-path-string components)
+  (string-join components "/"))
+
+(define (regexp-matches? rx value)
+  (if (byte-regexp? rx)
+      (regexp-match? rx (string->bytes/utf-8 value))
+      (regexp-match? rx value)))
+
+(define (custom-excluded-path? path exclude)
   (define components (path-component-strings path))
+  (define path-string (relative-path-string components))
+
+  (for/or ([entry (in-list exclude)])
+    (cond
+      ;; A string matches a file or directory name anywhere in the path.
+      [(string? entry)
+       (string-in? entry components)]
+
+      ;; A path matches that relative path and everything below it.
+      [(path? entry)
+       (path-prefix?
+        (path-component-strings (simplify-path entry #f))
+        components)]
+
+      ;; A regexp is applied to a platform-independent relative path.
+      [else
+       (regexp-matches? entry path-string)])))
+
+(define (excluded-path? path exclude)
+  (define components (path-component-strings path))
+  (define lower-components
+    (map string-downcase components))
   (define name
-    (if (null? components)
+    (if (null? lower-components)
         ""
-        (last components)))
+        (last lower-components)))
   (define extension
     (let ([ext (path-get-extension path)])
       (and ext
@@ -37,8 +74,9 @@
             (bytes->string/utf-8 ext)))))
 
   (or
-   ;; Git administration directory or file.
-   (string-in? ".git" components)
+   ;; Git administration and generated Racket bytecode directories.
+   (for/or ([component (in-list lower-components)])
+     (string-in? component excluded-directory-names))
 
    ;; Common editor and manual backup files.
    (string-suffix? name "~")
@@ -46,14 +84,53 @@
 
    ;; Generated Scribble web output.
    (and extension
-        (for/or ([component (in-list components)])
+        (for/or ([component (in-list lower-components)])
           (string-in? component scribble-directory-names))
-        (string-in? extension scribble-generated-extensions))))
+        (string-in? extension scribble-generated-extensions))
 
-(define (package-paths source-directory)
+   ;; Additional exclusions supplied by the caller.
+   (custom-excluded-path? path exclude)))
+
+(define (validate-exclude exclude)
+  (unless (list? exclude)
+    (raise-argument-error
+     'zip-package
+     "list?"
+     exclude))
+
+  (for ([entry (in-list exclude)])
+    (unless (or (string? entry)
+                (path? entry)
+                (regexp? entry)
+                (byte-regexp? entry))
+      (raise-arguments-error
+       'zip-package
+       "an exclude entry is not a string, path, or regular expression"
+       "entry" entry
+       "exclude" exclude))
+
+    (when (path? entry)
+      (define simplified-entry
+        (simplify-path entry #f))
+      (define parts
+        (explode-path simplified-entry))
+
+      (when (or (complete-path? simplified-entry)
+                (null? (path-component-strings simplified-entry))
+                (for/or ([part (in-list parts)])
+                  (not (path? part))))
+        (raise-arguments-error
+         'zip-package
+         "an exclude path must be a non-empty relative subpath without '..'"
+         "entry" entry
+         "exclude" exclude))))
+
+  exclude)
+
+(define (package-paths source-directory exclude)
   (parameterize ([current-directory source-directory])
     (find-files (lambda (path)
-                  (not (excluded-path? path)))
+                  (not (excluded-path? path exclude)))
                 #f
                 #:skip-filtered-directory? #t
                 #:follow-links? #f)))
@@ -92,11 +169,14 @@
 
   version)
 
-(define (zip-package [directory (current-directory)])
+(define (zip-package [directory (current-directory)]
+                     #:exclude [exclude null])
   (define source-directory
     (simplify-path
      (path->complete-path directory)
      #t))
+  (define checked-exclude
+    (validate-exclude exclude))
 
   (unless (directory-exists? source-directory)
     (raise-argument-error
@@ -114,7 +194,7 @@
                         package-name
                         version)))
   (define paths
-    (package-paths source-directory))
+    (package-paths source-directory checked-exclude))
 
   (when (file-exists? output-path)
     (delete-file output-path))
@@ -133,17 +213,44 @@
 (module+ test
   (require rackunit)
 
+  (define no-custom-exclude null)
+
   (check-true
-   (excluded-path? (string->path ".git/config")))
+   (excluded-path? (string->path ".git/config") no-custom-exclude))
   (check-true
-   (excluded-path? (string->path "private/source.rkt~")))
+   (excluded-path? (string->path "compiled/main_rkt.zo") no-custom-exclude))
   (check-true
-   (excluded-path? (string->path "private/source.BAK")))
+   (excluded-path? (string->path "private/compiled/helper_rkt.zo")
+                   no-custom-exclude))
   (check-true
-   (excluded-path? (string->path "scribblings/index.html")))
+   (excluded-path? (string->path "private/source.rkt~") no-custom-exclude))
   (check-true
-   (excluded-path? (string->path "scribbles/manual.JS")))
+   (excluded-path? (string->path "private/source.BAK") no-custom-exclude))
+  (check-true
+   (excluded-path? (string->path "scribblings/index.html") no-custom-exclude))
+  (check-true
+   (excluded-path? (string->path "scribbles/manual.JS") no-custom-exclude))
   (check-false
-   (excluded-path? (string->path "web/index.html")))
+   (excluded-path? (string->path "web/index.html") no-custom-exclude))
   (check-false
-   (excluded-path? (string->path "scribblings/package.scrbl"))))
+   (excluded-path? (string->path "scribblings/package.scrbl")
+                   no-custom-exclude))
+
+  (check-true
+   (excluded-path? (string->path "private/generated/result.txt")
+                   '("generated")))
+  (check-false
+   (excluded-path? (string->path "private/generated-result.txt")
+                   '("generated")))
+  (check-true
+   (excluded-path? (string->path "examples/generated/result.txt")
+                   (list (string->path "examples/generated"))))
+  (check-false
+   (excluded-path? (string->path "private/generated/result.txt")
+                   (list (string->path "examples/generated"))))
+  (check-true
+   (excluded-path? (string->path "tests/data/example.json")
+                   (list #rx"^tests/data/")))
+  (check-false
+   (excluded-path? (string->path "tests/example.json")
+                   (list #rx"^tests/data/"))))