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

raco setup: fix info-domain cleanup of unlinked planet packages

Browse Source
This commit is contained in:
Matthew Flatt 2014-04-28 19:03:39 -06:00
parent afb75c7cfe
commit dee331e3b1
1 changed files with 17 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
racket/collects/setup/setup-core.rkt
View File

@ -13,6 +13,7 @@
compiler/cm compiler/cm
planet/planet-archives planet/planet-archives
planet/private/planet-shared planet/private/planet-shared
(only-in planet/resolver resolve-planet-path)
"option.rkt" "option.rkt"
compiler/compiler compiler/compiler
@ -1050,7 +1051,21 @@
(equal? p (cc-path cc))) (equal? p (cc-path cc)))
p))))] p))))]
[(abs) [(abs)
(and (complete-path? p) p)])) (and (complete-path? p)
(match c
[(list 'planet (? string? a) (? string? p))
;; Check that the package is installed and maps to `p`:
(and (get-installed-package a p d e)
(let ([bp (resolve-planet-path
`(planet "bogus.rkt" (,a ,p ,d ,e)))])
(and (path? bp)
(let-values ([(base name dir?) (split-path bp)])
(and (path? base)
(equal? (path->directory-path p)
(path->directory-path base)))))))]
[else
#t])
p)]))
(if (and dir (if (and dir
(let ([omit-root (let ([omit-root
(if (path? p) (if (path? p)
@ -1134,7 +1149,7 @@
(get-info-ht info-root info-path 'abs-in-relative)) (get-info-ht info-root info-path 'abs-in-relative))
(define planet-info-path (get-planet-cache-path)) (define planet-info-path (get-planet-cache-path))
(when (file-exists? planet-info-path) (when (file-exists? planet-info-path)
(get-info-ht #f info-path 'abs)))) (get-info-ht #f planet-info-path 'abs))))
;; Write out each collection-root-specific table to a "cache.rktd" file: ;; Write out each collection-root-specific table to a "cache.rktd" file:
(hash-for-each ht (hash-for-each ht
(lambda (info-path ht) (lambda (info-path ht)