162 lines
6.5 KiB
Scheme
162 lines
6.5 KiB
Scheme
|
|
(module getinfo mzscheme
|
|
|
|
(require (lib "match.ss")
|
|
(lib "list.ss")
|
|
(lib "etc.ss")
|
|
|
|
(lib "contract.ss"))
|
|
|
|
(define info? (opt-> (symbol?) ((-> any/c)) any/c))
|
|
(define path-or-string? (lambda (x) (or (path? x) (string? x))))
|
|
|
|
(provide/contract
|
|
(get-info ((listof path-or-string?) . -> . (union info? boolean?)))
|
|
(get-info/full (path? . -> . (union info? boolean?)))
|
|
(find-relevant-directories (opt-> ((listof symbol?))
|
|
((lambda (x) (or (eq? x 'preferred)
|
|
(eq? x 'all-available))))
|
|
(listof path?))))
|
|
|
|
|
|
|
|
;; 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 (build-path (find-system-path 'addon-dir) "cache.ss"))
|
|
|
|
(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)))
|
|
|
|
(define (get-info/full dir)
|
|
(let ([file (build-path dir "info.ss")])
|
|
(if (file-exists? file)
|
|
(begin
|
|
(with-input-from-file file
|
|
(lambda ()
|
|
(let ([r (read)])
|
|
(unless (eof-object? (read))
|
|
(error "info.ss file has multiple expressions in ~a" dir))
|
|
(match r
|
|
[('module 'info '(lib "infotab.ss" "setup")
|
|
expr ...)
|
|
'ok]
|
|
[else (error
|
|
'get-info
|
|
"info file does not contain a module of the right shape: \"~a\""
|
|
file)]))))
|
|
(dynamic-require file '#%info-lookup))
|
|
#f)))
|
|
|
|
;; item : (list path (listof symbol) nat nat)
|
|
|
|
(define-struct table (insert ; item * listof item -> listof item
|
|
ht ; hashtable[key -o> item]
|
|
paths ; listof path
|
|
))
|
|
|
|
(define preferred-table
|
|
(make-table
|
|
(lambda (i l)
|
|
(cond
|
|
[(null? l)
|
|
(list i)]
|
|
[else
|
|
(match-let ([(_ _ my-maj my-min) i]
|
|
[(_ _ 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))
|
|
|
|
(define all-available-table (make-table cons #f #f))
|
|
|
|
(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-table 'equal)])
|
|
(for-each (lambda (f)
|
|
(when (file-exists? f)
|
|
(for-each
|
|
(lambda (i)
|
|
(match i
|
|
[((? bytes? pathbytes)
|
|
((? symbol? fields) ...)
|
|
key ;; anything is okay here
|
|
(? integer? maj)
|
|
(? integer? min))
|
|
(let ((old-items (hash-table-get
|
|
colls
|
|
key
|
|
(lambda () '())))
|
|
(new-item (list (bytes->path pathbytes) fields maj min)))
|
|
(hash-table-put! colls
|
|
key
|
|
((table-insert t) new-item old-items)))]
|
|
[_
|
|
(error 'find-relevant-directories
|
|
"bad info-domain cache entry: ~e in: ~a"
|
|
i
|
|
f)]))
|
|
(let ([l (with-input-from-file f read)])
|
|
(unless (list? l)
|
|
(error 'find-relevant-directories
|
|
"bad info-domain cache file: ~a"
|
|
f))
|
|
l))))
|
|
(reverse (table-paths t)))
|
|
;; For each coll, invert the mapping, adding the col name to the list for each sym:
|
|
(hash-table-for-each colls
|
|
(lambda (key vals)
|
|
(for-each
|
|
(lambda (val)
|
|
(match val
|
|
[(path syms maj min)
|
|
(for-each (lambda (sym)
|
|
(hash-table-put!
|
|
(table-ht t)
|
|
sym
|
|
(cons path (hash-table-get (table-ht t) sym (lambda () null)))))
|
|
syms)]
|
|
[_ (error 'get-info
|
|
"Internal error: invalid info-domain value format: ~s" val)]))
|
|
vals)))))
|
|
|
|
(define find-relevant-directories
|
|
(opt-lambda (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)]))
|
|
|
|
(define search-path
|
|
(cons user-infotable
|
|
(map (lambda (coll) (build-path coll "info-domain" "compiled" "cache.ss"))
|
|
(current-library-collection-paths))))
|
|
|
|
(unless (equal? (table-paths t) search-path)
|
|
(set-table-ht! t (make-hash-table))
|
|
(set-table-paths! t search-path)
|
|
(populate-table! t))
|
|
|
|
(let ([unsorted (if (= (length syms) 1)
|
|
;; Simple case: look up in table
|
|
(hash-table-get (table-ht t) (car syms) (lambda () null))
|
|
;; Use a hash table, because the same collection might work for multiple syms
|
|
(let ([result (make-hash-table 'equal)])
|
|
(for-each (lambda (sym)
|
|
(let ([l (hash-table-get (table-ht t) sym (lambda () null))])
|
|
(for-each (lambda (c) (hash-table-put! result c #t))
|
|
l)))
|
|
syms)
|
|
;; Extract the relevant collections:
|
|
(hash-table-map result (lambda (k v) k))))])
|
|
(quicksort unsorted compare-directories))))
|
|
|
|
(define (compare-directories a b)
|
|
(bytes<? (path->bytes a) (path->bytes b))))
|