suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Ignore duplicate collection specified, including ones that are

Browse Source 
implicitly specified because they're a subcollection of another that is
specified.

svn: r16555
This commit is contained in:
Eli Barzilay 2009-11-05 08:51:29 +00:00
parent 2b026c63ac
commit a68c6c8005
1 changed files with 60 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

101
collects/setup/setup-unit.ss
View File

@ -197,21 +197,24 @@
v) v)
;; collection->cc : listof path -> cc/#f ;; collection->cc : listof path -> cc/#f
(define collection->cc-table (make-hash))
(define (collection->cc collection-p) (define (collection->cc collection-p)
(let ([root-dir (hash-ref! collection->cc-table collection-p
(ormap (lambda (p) (lambda ()
(parameterize ([current-library-collection-paths (list p)]) (define root-dir
(and (with-handlers ([exn:fail? (lambda (x) #f)]) (ormap (lambda (p)
(apply collection-path collection-p)) (parameterize ([current-library-collection-paths (list p)])
p))) (and (with-handlers ([exn:fail? (lambda (x) #f)])
(current-library-collection-paths))]) (apply collection-path collection-p))
(make-cc* collection-p p)))
(apply collection-path collection-p) (current-library-collection-paths)))
root-dir (make-cc* collection-p
(build-path root-dir "info-domain" "compiled" "cache.ss") (apply collection-path collection-p)
;; by convention, all collections have "version" 1 0. This root-dir
;; forces them to conflict with each other. (build-path root-dir "info-domain" "compiled" "cache.ss")
(list (cons 'lib (map path->string collection-p)) 1 0)))) ;; by convention, all collections have "version" 1 0. This
;; forces them to conflict with each other.
(list (cons 'lib (map path->string collection-p)) 1 0)))))
;; planet-spec->planet-list : (list string string nat nat) -> (list path string string (listof string) nat nat) | #f ;; planet-spec->planet-list : (list string string nat nat) -> (list path string string (listof string) nat nat) | #f
;; converts a planet package spec into the information needed to create a cc structure ;; converts a planet package spec into the information needed to create a cc structure
@ -305,17 +308,31 @@
subs)))) subs))))
(define (check-again-all given-ccs) (define (check-again-all given-ccs)
(define (cc->name cc)
(string-join (map path->string (cc-collection cc)) "/"))
(define (cc->cc+name+id cc) (define (cc->cc+name+id cc)
(list cc (list cc (cc->name cc) (file-or-directory-identity (cc-path cc))))
(string-join (map path->string (cc-collection cc)) "/")
(file-or-directory-identity (cc-path cc))))
(define all-ccs+names+ids (define all-ccs+names+ids
(map cc->cc+name+id (plt-collection-closure all-collections))) (map cc->cc+name+id (plt-collection-closure all-collections)))
(define given-ccs+names+ids ;; given collections
(define given-ccs+names+ids (map cc->cc+name+id given-ccs))
;; descendants of given collections
(define descendants-names
(remove-duplicates (remove-duplicates
(map cc->cc+name+id (plt-collection-closure given-ccs)) (append-map
(lambda (cc)
(map cc->name (remq cc (plt-collection-closure (list cc)))))
given-ccs)))
;; given collections without duplicates and without ones that are already
;; descendants
(define given*-ccs+names+ids
(remove-duplicates
(filter (lambda (cc+name+id)
(not (member (cadr cc+name+id) descendants-names)))
given-ccs+names+ids)
(lambda (x y) (equal? (cadr x) (cadr y))))) (lambda (x y) (equal? (cadr x) (cadr y)))))
(for ([given-cc+name+id (in-list given-ccs+names+ids)]) ;; check that there are no bad duplicates in the given list
(for ([given-cc+name+id (in-list given*-ccs+names+ids)])
(cond (cond
[(ormap (lambda (cc+name+id) [(ormap (lambda (cc+name+id)
(and (not (equal? (cadr cc+name+id) (cadr given-cc+name+id))) (and (not (equal? (cadr cc+name+id) (cadr given-cc+name+id)))
@ -326,7 +343,7 @@
(error 'setup-plt (error 'setup-plt
"given collection path: \"~a\" refers to the same directory as another given collection path, \"~a\"" "given collection path: \"~a\" refers to the same directory as another given collection path, \"~a\""
(cadr given-cc+name+id) bad))])) (cadr given-cc+name+id) bad))]))
(map car given-ccs+names+ids)) (map car given*-ccs+names+ids))
(define (sort-collections ccs) (define (sort-collections ccs)
(sort ccs string<? #:key cc-name)) (sort ccs string<? #:key cc-name))
@ -465,7 +482,7 @@
[else (void)]))))))) [else (void)])))))))
(when (clean) (when (clean)
(setup-printf #f "--- cleaning collections ---") (setup-printf #f "--- cleaning collections ---")
(let ([dependencies (make-hash)]) (let ([dependencies (make-hash)])
;; Main deletion: ;; Main deletion:
(for ([cc ccs-to-compile]) (clean-collection cc dependencies)) (for ([cc ccs-to-compile]) (clean-collection cc dependencies))
@ -618,25 +635,27 @@
(setup-printf #f "--- compiling collections ---") (setup-printf #f "--- compiling collections ---")
(with-specified-mode (with-specified-mode
(lambda () (lambda ()
(make-it ".zos" (make-it
(lambda (dir info) ".zos"
;; Clean up bad .zos: (lambda (dir info)
(unless (info 'assume-virtual-sources (lambda () #f)) ;; Clean up bad .zos:
(let ([c (build-path dir "compiled")]) (unless (info 'assume-virtual-sources (lambda () #f))
(when (directory-exists? c) (let ([c (build-path dir "compiled")])
(let ([ok-zo-files (make-immutable-hash (when (directory-exists? c)
(map (lambda (p) (let ([ok-zo-files
(cons (path-add-suffix p #".zo") #t)) (make-immutable-hash
(append (directory-list dir) (map (lambda (p)
(info 'virtual-sources (lambda () null)))))]) (cons (path-add-suffix p #".zo") #t))
(for ([p (directory-list c)]) (append (directory-list dir)
(when (and (regexp-match #rx#".zo$" (path-element->bytes p)) (info 'virtual-sources (lambda () null)))))])
(not (hash-ref ok-zo-files p #f))) (for ([p (directory-list c)])
(setup-fprintf (current-error-port) #f " deleting ~a" (build-path c p)) (when (and (regexp-match #rx#".zo$" (path-element->bytes p))
(delete-file (build-path c p)))))))) (not (hash-ref ok-zo-files p #f)))
;; Make .zos (setup-fprintf (current-error-port) #f " deleting ~a" (build-path c p))
(compile-directory-zos dir info #:skip-path compile-skip-directory #:skip-doc-sources? (not (make-docs)))) (delete-file (build-path c p))))))))
make-base-empty-namespace)))) ;; Make .zos
(compile-directory-zos dir info #:skip-path compile-skip-directory #:skip-doc-sources? (not (make-docs))))
make-base-empty-namespace))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Info-Domain Cache ;; ;; Info-Domain Cache ;;