* 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
This commit is contained in:
Eli Barzilay
parent
2a16188855
commit
850af38cfe
|
|
@ -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)
|
||||
|
|
|
|||
105
collects/setup/private/omitted-paths.ss
Normal file
105
collects/setup/private/omitted-paths.ss
Normal file
|
|
@ -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)))
|
||||
|
|
@ -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)
|
||||
;; 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 (path->string p) omit))))
|
||||
(directory-list ccp))])
|
||||
(not (member p omit))))
|
||||
(directory-list ccp)))])
|
||||
(filter values (make-subs cc subs))))
|
||||
(filter values
|
||||
(let loop ([l collections-to-compile])
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user