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

43
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
(lambda ()
(define root-dir
(ormap (lambda (p) (ormap (lambda (p)
(parameterize ([current-library-collection-paths (list p)]) (parameterize ([current-library-collection-paths (list p)])
(and (with-handlers ([exn:fail? (lambda (x) #f)]) (and (with-handlers ([exn:fail? (lambda (x) #f)])
(apply collection-path collection-p)) (apply collection-path collection-p))
p))) p)))
(current-library-collection-paths))]) (current-library-collection-paths)))
(make-cc* collection-p (make-cc* collection-p
(apply collection-path collection-p) (apply collection-path collection-p)
root-dir root-dir
(build-path root-dir "info-domain" "compiled" "cache.ss") (build-path root-dir "info-domain" "compiled" "cache.ss")
;; by convention, all collections have "version" 1 0. This ;; by convention, all collections have "version" 1 0. This
;; forces them to conflict with each other. ;; forces them to conflict with each other.
(list (cons 'lib (map path->string collection-p)) 1 0)))) (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))
@ -618,13 +635,15 @@
(setup-printf #f "--- compiling collections ---") (setup-printf #f "--- compiling collections ---")
(with-specified-mode (with-specified-mode
(lambda () (lambda ()
(make-it ".zos" (make-it
".zos"
(lambda (dir info) (lambda (dir info)
;; Clean up bad .zos: ;; Clean up bad .zos:
(unless (info 'assume-virtual-sources (lambda () #f)) (unless (info 'assume-virtual-sources (lambda () #f))
(let ([c (build-path dir "compiled")]) (let ([c (build-path dir "compiled")])
(when (directory-exists? c) (when (directory-exists? c)
(let ([ok-zo-files (make-immutable-hash (let ([ok-zo-files
(make-immutable-hash
(map (lambda (p) (map (lambda (p)
(cons (path-add-suffix p #".zo") #t)) (cons (path-add-suffix p #".zo") #t))
(append (directory-list dir) (append (directory-list dir)