32297601b6
--- a reversal of opinion from my earlier commit; the problem with syntactic simplification is that it may not refer to the same file, due to soft links; given that true normalization is impossible, simplify-path and simple-form-path provide a good compromise between preserving paths as given and exanding soft links as neede
54 lines
2.3 KiB
Racket
54 lines
2.3 KiB
Racket
#lang scheme/base
|
|
|
|
(require (prefix-in planet: planet/config) scheme/path scheme/list)
|
|
|
|
;; `library-roots' is an alist of root-path, and the number of levels
|
|
;; below that which indicates a "library". This is hard-wired now to
|
|
;; the different roots, and should probably be improved at some point.
|
|
;; `path->library-root' takes in a path and returns a path to the root
|
|
;; of its library, defined by the above. (Assumes that none of the
|
|
;; roots is a subdirectory of another.)
|
|
|
|
(provide library-roots path->library-root)
|
|
|
|
(define library-roots
|
|
`(,@(map (lambda (p) (cons p 1)) (current-library-collection-paths))
|
|
,(cons (planet:CACHE-DIR) 4)
|
|
;; add planet links, each as a root (if there is a change in
|
|
;; the format, this will just ignore these paths, but these
|
|
;; collections will throw an error in setup-plt)
|
|
,@(with-handlers ([exn? (lambda (e)
|
|
(printf "WARNING: bad planet links at ~a:\n ~a"
|
|
(planet:HARD-LINK-FILE) (exn-message e))
|
|
'())])
|
|
(if (not (file-exists? (planet:HARD-LINK-FILE)))
|
|
'()
|
|
(with-input-from-file (planet:HARD-LINK-FILE)
|
|
(lambda ()
|
|
(let loop ([r '()])
|
|
(let ([x (read)])
|
|
(if (eof-object? x)
|
|
(reverse r)
|
|
(let ([x (and (list? x) (= 7 (length x)) (list-ref x 4))])
|
|
(loop (if (bytes? x)
|
|
(cons (cons (simple-form-path (bytes->path x)) 0) r)
|
|
r))))))))))))
|
|
|
|
(define path->library-root
|
|
(let ([t #f])
|
|
(define (init-table)
|
|
(set! t (make-hash))
|
|
(for ([x (in-list library-roots)])
|
|
(hash-set! t (reverse (explode-path (car x))) (cdr x))))
|
|
(lambda (path)
|
|
(unless (complete-path? path)
|
|
(raise-type-error 'path->library-root "complete-path" path))
|
|
(unless t (init-table))
|
|
(let loop ([rpath (reverse (explode-path (simple-form-path path)))]
|
|
[subdir '()])
|
|
(let ([x (hash-ref t rpath #f)])
|
|
(cond [(and x ((length subdir) . >= . x))
|
|
(apply build-path (append (reverse rpath) (take subdir x)))]
|
|
[(or x (null? rpath)) #f]
|
|
[else (loop (cdr rpath) (cons (car rpath) subdir))]))))))
|