* Added `setup/private/omitted-paths' as a central point for getting

omitted paths -- including entries from parent directories
* This code automatically includes "compiled", ".*" and "doc" (unless
  in the main tree), which nicely unifies the pieces of code that
  duplicated this check (compiler/compiler-unit and setup/setup-unit).

svn: r11324

collects/compiler/compiler-unit.ss

@@ -24,7 +24,8 @@
          mzlib/compile ; gets compile-file
          compiler/cm
          setup/getinfo
-         setup/main-collects)
+         setup/main-collects
+         setup/private/omitted-paths)
 
 (provide compiler@)
 
@@ -135,9 +136,7 @@
 
   (define (compile-directory dir info #:verbose [verbose? #t])
     (define info* (or info (lambda (key mk-default) (mk-default))))
-    (define nothing (lambda () null))
+    (define omit-paths (omitted-paths dir))
-    (define omit-paths (info* 'compile-omit-paths nothing))
-    (define omit-files (info* 'compile-omit-files nothing))
     (unless (eq? 'all omit-paths)
       (parameterize ([current-directory dir]
                      [current-load-relative-directory dir]
@@ -151,27 +150,16 @@
                       ;; Find all .ss/.scm files:
                       (filter extract-base-filename/ss (directory-list))
                       ;; Add specified doc sources:
-                      (map car (info* 'scribblings nothing)))]
+                      (map car (info* 'scribblings (lambda () null))))]
-               [sses (remove* (map string->path omit-paths) sses)]
+               [sses (remove* omit-paths sses)])
-               [sses (remove* (map string->path omit-files) sses)])
           (for-each (make-caching-managed-compile-zo) sses)))
       (when (compile-subcollections)
         (when (info* 'compile-subcollections (lambda () #f))
           (printf "Warning: ignoring `compile-subcollections' entry in info ~a\n"
                   dir))
         (for ([p (directory-list dir)])
-          (let ([p* (build-path dir p)]
+          (let ([p* (build-path dir p)])
-                [s  (path->string p)])
+            (when (and (directory-exists? p*) (not (member p omit-paths)))
-            (when (and
-                   (directory-exists? p*)
-                   (not
-                    ;; this is the same check that setup/setup-unit is
-                    ;; doing in `make-cc*'
-                    (or (regexp-match? #rx"^[.]" s)
-                        (equal? "compiled" s)
-                        (and (equal? "doc" s)
-                             (not (pair? (path->main-collects-relative p*))))
-                        (and (pair? omit-paths) (member s omit-paths)))))
               (compile-directory p* (get-info/full p*))))))))
 
   (define (compile-collection-zos collection . cp)

collects/setup/private/omitted-paths.ss

@@ -0,0 +1,105 @@
+#lang scheme/base
+
+;; `omitted-paths' returns a list of omitted file and subdirectory names for a
+;; given directory, or 'all if the directory is completely omitted.  Considers
+;; the local info.ss as well as info.ss in parent directories all the way to a
+;; collection root.  (Could be a bit easier using `find-relevant-directories',
+;; but it needs to be available for setup-plt, before the "info-domain" caches
+;; are created.)
+
+(provide omitted-paths)
+
+(require scheme/path scheme/list "../dirs.ss" "../getinfo.ss"
+         (prefix-in planet: planet/config))
+
+;; An entry for each collections root that holds a hash table.  The hash table
+;; maps a reversed list of subpath elements to the exploded omitted-paths
+;; specified by the info files accumulated at that subpath for that subpath --
+;; filtered to only relevant ones.  Some entries are added automatically:
+;; "compiled", directories that begin with a ".", and "doc" unless it's in the
+;; main collection tree (it is not used there for documentation, and there is
+;; at least one place where it contains code: scribble/doc).
+(define roots
+  (map (lambda (p)
+         (list (explode-path p) (make-hash)
+               ;; don't omit "doc" in the main tree
+               (not (equal? (find-collects-dir) p))))
+       (cons (planet:CACHE-DIR) (current-library-collection-paths))))
+
+;; if `x' has `y' as a prefix, return the tail,
+;; eg (relative-from '(1 2 3 4) '(1 2)) => '(3 4)
+(define (relative-from x y)
+  (cond [(null? y) x]
+        [(null? x) #f]
+        [(equal? (car x) (car y)) (relative-from (cdr x) (cdr y))]
+        [else #f]))
+
+(define-syntax-rule (with-memo t x expr)
+  (hash-ref t x (lambda () (let ([r expr]) (hash-set! t x r) r))))
+
+(define ((implicit-omit? omit-doc?) path)
+  (let ([str (path-element->string path)])
+    (or (member str '("compiled" "CVS"))
+        (and omit-doc? (equal? "doc" str))
+        (regexp-match? #rx"^[.]" str))))
+
+(define (omitted-paths* dir)
+  (define (get rsubs root t omit-doc?)
+    (let loop ([rsubs rsubs])
+      (if (null? rsubs)
+        '()
+        (with-memo t rsubs
+          (let ([up (loop (cdr rsubs))])
+            (if (or (eq? 'all up) (member (list (car rsubs)) up))
+              'all
+              (let* ([dir (apply build-path (append root (reverse rsubs)))]
+                     [info (or (get-info/full dir) (lambda _ '()))]
+                     [explicit (info 'compile-omit-paths (lambda () '()))]
+                     [explicit (if (eq? 'all explicit)
+                                 'all
+                                 (map (lambda (e)
+                                        (explode-path (simplify-path e #f)))
+                                      (append explicit
+                                              ;; for backward compatibility
+                                              (info 'compile-omit-files
+                                                    (lambda () '())))))])
+                (cond
+                  [(or (eq? 'all explicit) (memq 'same explicit)) 'all]
+                  [(findf (lambda (e)
+                            (or (null? e)
+                                (not (path? (car e)))
+                                (absolute-path? (car e))))
+                          explicit)
+                   => (lambda (bad)
+                        (error 'compile-omit-paths
+                               "bad entry value in info file: ~e"
+                               (apply build-path bad)))]
+                  [else `(,@explicit
+                          ,@(map list (filter (implicit-omit? omit-doc?)
+                                              (directory-list dir)))
+                          ,@(filter-map (lambda (up)
+                                          (and (equal? (car up) (car rsubs))
+                                               ;; must have non-null cdr, due
+                                               ;; to the above `member' check
+                                               (cdr up)))
+                                        up))]))))))))
+  (unless (and (path-string? dir) (complete-path? dir) (directory-exists? dir))
+    (raise-type-error 'omitted-paths
+                      "complete path to an existing directory" dir))
+  (let* ([dir* (explode-path (simplify-path dir))]
+         [r (ormap (lambda (root+table)
+                     (let ([r (relative-from dir* (car root+table))])
+                       (and r (cons (reverse r) root+table))))
+                 roots)]
+         [r (and r (apply get r))])
+    (unless r
+      (error 'omitted-paths
+             "given directory path is not in any collection root: ~e" dir))
+    (if (eq? 'all r)
+      r
+      (filter-map (lambda (x) (and (null? (cdr x)) (car x))) r))))
+
+(define omitted-paths-memo (make-hash))
+
+(define (omitted-paths dir)
+  (with-memo omitted-paths-memo dir (omitted-paths* dir)))

collects/setup/setup-unit.ss

@@ -22,7 +22,8 @@
          "getinfo.ss"
          "dirs.ss"
          "main-collects.ss"
-         "private/path-utils.ss")
+         "private/path-utils.ss"
+         "private/omitted-paths.ss")
 
 (define-namespace-anchor anchor)
 
@@ -180,22 +181,12 @@
                   "'name' result from collection ~e is not a string: ~e"
                   path x)))))
     (define path-name (path->name path))
-    (define basename
-      (let-values ([(base name dir?) (split-path path)])
-        (if (path? name)
-          (path-element->string name)
-          (error 'make-cc*
-                 "Internal error: cc had invalid info-path: ~e" path))))
     (when (info 'compile-subcollections (lambda () #f))
       (setup-printf "WARNING"
                     "ignoring `compile-subcollections' entry in info ~a"
                     path-name))
     ;; this check is also done in compiler/compiler-unit, in compile-directory
-    (and (not (or (regexp-match? #rx"^[.]" basename)
+    (and (not (eq? 'all (omitted-paths path)))
-                  (equal? "compiled" basename)
-                  (and (equal? "doc" basename)
-                       (not (pair? (path->main-collects-relative path))))
-                  (eq? 'all (info 'compile-omit-paths void))))
          (make-cc collection path
                   (if name (string-append path-name " (" name ")") path-name)
                   info root-dir info-path shadowing-policy)))
@@ -287,21 +278,17 @@
     (define (get-subs cc)
       (let* ([info (cc-info cc)]
              [ccp (cc-path cc)]
-             ;; note: `compile-omit-paths' can be the symbol `all', if this
+             ;; note: omit can be 'all, if this happens then this
-             ;; happens then this collection should not have been included in
+             ;; collection should not have been included, but we might
-             ;; the first place, but we might jump in if a command-line
+             ;; jump in if a command-line argument specified a
-             ;; argument specifies coll/subcoll
+             ;; coll/subcoll
-             [omit (call-info info 'compile-omit-paths (lambda () '())
+             [omit (omitted-paths ccp)]
-                              (lambda (x)
+             [subs (if (eq? 'all omit)
-                                (unless (or (eq? 'all x) (list-of string? x))
+                     '()
-                                  (error 'setup-plt
+                     (filter (lambda (p)
-                                         "expected a list of path strings or 'all for compile-omit-paths, got: ~s"
+                               (and (directory-exists? (build-path ccp p))
-                                         x))))]
+                                    (not (member p omit))))
-             [omit (if (pair? omit) omit '())]
+                             (directory-list ccp)))])
-             [subs (filter (lambda (p)
-                             (and (directory-exists? (build-path ccp p))
-                                  (not (member (path->string p) omit))))
-                           (directory-list ccp))])
         (filter values (make-subs cc subs))))
     (filter values
             (let loop ([l collections-to-compile])