From 850af38cfe858c51fadeca7a1384a4235e5749a2 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 19 Aug 2008 10:28:22 +0000 Subject: [PATCH] * 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 | 26 ++---- collects/setup/private/omitted-paths.ss | 105 ++++++++++++++++++++++++ collects/setup/setup-unit.ss | 41 ++++----- 3 files changed, 126 insertions(+), 46 deletions(-) create mode 100644 collects/setup/private/omitted-paths.ss diff --git a/collects/compiler/compiler-unit.ss b/collects/compiler/compiler-unit.ss index 8e33b1c40e..1d68dfad51 100644 --- a/collects/compiler/compiler-unit.ss +++ b/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 (info* 'compile-omit-paths nothing)) - (define omit-files (info* 'compile-omit-files nothing)) + (define omit-paths (omitted-paths dir)) (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)))] - [sses (remove* (map string->path omit-paths) sses)] - [sses (remove* (map string->path omit-files) sses)]) + (map car (info* 'scribblings (lambda () null))))] + [sses (remove* omit-paths 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)] - [s (path->string p)]) - (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))))) + (let ([p* (build-path dir p)]) + (when (and (directory-exists? p*) (not (member p omit-paths))) (compile-directory p* (get-info/full p*)))))))) (define (compile-collection-zos collection . cp) diff --git a/collects/setup/private/omitted-paths.ss b/collects/setup/private/omitted-paths.ss new file mode 100644 index 0000000000..50d262d36e --- /dev/null +++ b/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))) diff --git a/collects/setup/setup-unit.ss b/collects/setup/setup-unit.ss index 68e9670b8e..db5aaaf63a 100644 --- a/collects/setup/setup-unit.ss +++ b/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) - (equal? "compiled" basename) - (and (equal? "doc" basename) - (not (pair? (path->main-collects-relative path)))) - (eq? 'all (info 'compile-omit-paths void)))) + (and (not (eq? 'all (omitted-paths path))) (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 - ;; happens then this collection should not have been included in - ;; the first place, but we might jump in if a command-line - ;; argument specifies coll/subcoll - [omit (call-info info 'compile-omit-paths (lambda () '()) - (lambda (x) - (unless (or (eq? 'all x) (list-of string? x)) - (error 'setup-plt - "expected a list of path strings or 'all for compile-omit-paths, got: ~s" - x))))] - [omit (if (pair? omit) omit '())] - [subs (filter (lambda (p) - (and (directory-exists? (build-path ccp p)) - (not (member (path->string p) omit)))) - (directory-list ccp))]) + ;; note: omit can be 'all, if this happens then this + ;; collection should not have been included, but we might + ;; jump in if a command-line argument specified a + ;; coll/subcoll + [omit (omitted-paths ccp)] + [subs (if (eq? 'all omit) + '() + (filter (lambda (p) + (and (directory-exists? (build-path ccp p)) + (not (member p omit)))) + (directory-list ccp)))]) (filter values (make-subs cc subs)))) (filter values (let loop ([l collections-to-compile])