194 lines
7.7 KiB
Scheme
194 lines
7.7 KiB
Scheme
#lang scheme/base
|
|
|
|
(require scheme/match scheme/contract planet/cachepath)
|
|
|
|
;; in addition to infodomain/compiled/cache.ss, getinfo will look in this
|
|
;; file to find mappings. PLaneT uses this to put info about installed
|
|
;; planet packages.
|
|
(define user-infotable (get-planet-cache-path))
|
|
|
|
;; get-info : (listof path-or-string) -> info/#f
|
|
(define (get-info coll-path)
|
|
(let* ([coll-path (map (lambda (x) (if (path? x) (path->string x) x)) coll-path)]
|
|
[dir (apply collection-path coll-path)])
|
|
(get-info/full dir)))
|
|
|
|
;; get-info/full : path -> info/#f
|
|
(define (get-info/full dir)
|
|
(define file (build-path dir "info.ss"))
|
|
(define (err fmt . args)
|
|
(apply error 'get-info (string-append "info file " fmt " in ~a")
|
|
(append args (list file))))
|
|
(define (contents)
|
|
(parameterize ([read-accept-reader #t]
|
|
[current-reader-guard
|
|
(lambda (x)
|
|
(if (eq? x 'setup/infotab/lang/reader)
|
|
x
|
|
(err "has illegal #lang or #reader"))
|
|
x)])
|
|
(with-input-from-file file
|
|
(lambda ()
|
|
(begin0 (read)
|
|
(unless (eof-object? (read))
|
|
(err "has multiple expressions")))))))
|
|
(and (file-exists? file)
|
|
(match (contents)
|
|
[(list 'module 'info
|
|
(or '(lib "infotab.ss" "setup") 'setup/infotab)
|
|
expr ...)
|
|
;; No need to set a reader-guard, since we checked it
|
|
;; above (a guard will see other uses of #lang for stuff
|
|
;; that is required).
|
|
;; We are, however, trusting that the bytecode form of the
|
|
;; file (if any) matches the source.
|
|
(dynamic-require file '#%info-lookup)]
|
|
[else (err "does not contain a module of the right shape")])))
|
|
|
|
;; directory-record = (make-directory-record nat nat key path (listof symbol))
|
|
;; eg: (make-directory-record 1 0 '(lib "mzlib") #"mzlib" '(name))
|
|
(define-struct directory-record (maj min spec path syms))
|
|
|
|
(define-struct table (insert ; directory-record (listof directory-record)
|
|
; -> (listof directory-record)
|
|
ht ; hashtable[symbol -o> directory-record]
|
|
paths ; (listof (cons path boolean))
|
|
)
|
|
#:mutable)
|
|
|
|
(define preferred-table #f)
|
|
(define all-available-table #f)
|
|
|
|
;; reset-relevant-directories-state! : -> void
|
|
(define (reset-relevant-directories-state!)
|
|
(set! preferred-table
|
|
(make-table
|
|
(lambda (i l)
|
|
(if (null? l)
|
|
(list i)
|
|
(match-let ([(struct directory-record (my-maj my-min _ _ _)) i]
|
|
[(struct directory-record (their-maj their-min _ _ _))
|
|
(car l)])
|
|
(if (or (> my-maj their-maj)
|
|
(and (= my-maj their-maj) (>= my-min their-min)))
|
|
(list i)
|
|
l))))
|
|
#f #f))
|
|
(set! all-available-table (make-table cons #f #f)))
|
|
|
|
(reset-relevant-directories-state!)
|
|
|
|
;; populate-table : table -> void
|
|
(define (populate-table! t)
|
|
;; Use the colls ht because a collection might be in multiple
|
|
;; collection paths, and we only want one
|
|
(let ([colls (make-hash)])
|
|
(for ([f+root-dir (reverse (table-paths t))])
|
|
(let ([f (car f+root-dir)]
|
|
[root-dir (cdr f+root-dir)])
|
|
(when (file-exists? f)
|
|
(for ([i (let ([l (with-input-from-file f read)])
|
|
(cond [(list? l) l]
|
|
[(eof-object? l) '()] ;; allow completely empty files
|
|
[else (error 'find-relevant-directories
|
|
"bad info-domain cache file: ~a" f)]))])
|
|
(match i
|
|
[(list (? bytes? pathbytes)
|
|
(list (? symbol? fields) ...)
|
|
key ;; anything is okay here
|
|
(? integer? maj)
|
|
(? integer? min))
|
|
(let ([old-items (hash-ref colls key null)]
|
|
[new-item
|
|
(make-directory-record
|
|
maj min key
|
|
(let ([p (bytes->path pathbytes)])
|
|
(if (and (relative-path? p) root-dir)
|
|
(build-path root-dir p)
|
|
p))
|
|
fields)])
|
|
(hash-set! colls key
|
|
((table-insert t) new-item old-items)))]
|
|
[_ (error 'find-relevant-directories
|
|
"bad info-domain cache entry: ~e in: ~a" i f)])))))
|
|
;; For each coll, invert the mapping, adding the col name to the list
|
|
;; for each sym:
|
|
(for* ([(key vals) colls]
|
|
[val vals])
|
|
(match val
|
|
[(struct directory-record (maj min spec path syms))
|
|
(for ([sym syms])
|
|
(hash-set! (table-ht t) sym
|
|
(cons val (hash-ref (table-ht t) sym null))))]
|
|
[_ (error 'get-info
|
|
"Internal error: invalid info-domain value format: ~s" val)]))))
|
|
|
|
(define (find-relevant-directories syms [key 'preferred])
|
|
(map directory-record-path (find-relevant-directory-records syms key)))
|
|
|
|
(define (find-relevant-directory-records syms [key 'preferred])
|
|
(define t
|
|
(cond [(eq? key 'preferred) preferred-table]
|
|
[(eq? key 'all-available) all-available-table]
|
|
[else (error 'find-relevant-directories "Invalid key: ~s" key)]))
|
|
;; A list of (cons cache.ss-path root-dir-path)
|
|
;; If root-dir-path is not #f, then paths in the cache.ss
|
|
;; file are relative to it. #f is used for the planet cache.ss file.
|
|
(define search-path
|
|
(cons (cons user-infotable #f)
|
|
(map (lambda (coll)
|
|
(cons (build-path coll "info-domain" "compiled" "cache.ss")
|
|
coll))
|
|
(current-library-collection-paths))))
|
|
(unless (equal? (table-paths t) search-path)
|
|
(set-table-ht! t (make-hasheq))
|
|
(set-table-paths! t search-path)
|
|
(populate-table! t))
|
|
(let ([unsorted
|
|
(if (= (length syms) 1)
|
|
;; Simple case: look up in table
|
|
(hash-ref (table-ht t) (car syms) null)
|
|
;; Use a hash table, because the same collection might work
|
|
;; for multiple syms
|
|
(let ([result (make-hash)])
|
|
(for* ([sym syms]
|
|
[c (hash-ref (table-ht t) sym null)])
|
|
(hash-set! result c #t))
|
|
;; Extract the relevant collections:
|
|
(hash-map result (lambda (k v) k))))])
|
|
(sort unsorted
|
|
(lambda (a b)
|
|
(compare-directories (directory-record-path a)
|
|
(directory-record-path b))))))
|
|
|
|
(define (compare-directories a b)
|
|
(bytes<? (dir->sort-key a) (dir->sort-key b)))
|
|
|
|
;; dir->sort-key : path -> bytes
|
|
;; extracts the name of the directory, dropping any "."s it finds at the ends.
|
|
(define (dir->sort-key path)
|
|
(let-values ([(base name dir?) (split-path path)])
|
|
(if (eq? name 'same) (dir->sort-key base) (path->bytes name))))
|
|
|
|
(define info? (->* [symbol?] [(-> any/c)] any/c))
|
|
(define path-or-string? (lambda (x) (or (path? x) (string? x))))
|
|
|
|
(provide/contract
|
|
(reset-relevant-directories-state! (-> any))
|
|
(get-info ((listof path-or-string?) . -> . (or/c info? boolean?)))
|
|
(get-info/full (path? . -> . (or/c info? boolean?)))
|
|
(find-relevant-directories
|
|
(->* [(listof symbol?)]
|
|
[(lambda (x) (memq x '(preferred all-available)))]
|
|
(listof path?)))
|
|
(struct directory-record
|
|
([maj integer?]
|
|
[min integer?]
|
|
[spec any/c]
|
|
[path path?]
|
|
[syms (listof symbol?)]))
|
|
(find-relevant-directory-records
|
|
(->* [(listof symbol?)]
|
|
[(lambda (x) (memq x '(preferred all-available)))]
|
|
(listof directory-record?))))
|