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

Added tool manager to DrScheme (preferences panel)

Browse Source 
More information available via setup/getinfo.ss
Changed help desk to show more info for package docs

svn: r7155
This commit is contained in:
Ryan Culpepper 2007-08-23 22:07:00 +00:00
parent 34765705a5
commit cdd9c7d0ce
7 changed files with 463 additions and 228 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/drscheme/private/drsig.ss
View File

@ -109,7 +109,8 @@
((struct successful-tool (spec bitmap name url)) ((struct successful-tool (spec bitmap name url))
get-successful-tools get-successful-tools
only-in-phase only-in-phase
load/invoke-all-tools)) load/invoke-all-tools
add-prefs-panel))
(define-signature drscheme:get/extend^ (define-signature drscheme:get/extend^
(extend-tab (extend-tab

11
collects/drscheme/private/main.ss
View File

@ -192,6 +192,16 @@
(preferences:set-default 'drscheme:switch-to-module-language-automatically? #t boolean?) (preferences:set-default 'drscheme:switch-to-module-language-automatically? #t boolean?)
(preferences:set-default
'drscheme:default-tools-configuration
'load
(lambda (p)
(memq p '(load skip))))
(preferences:set-default
'drscheme:tools-configuration
null
list?)
(drscheme:font:setup-preferences) (drscheme:font:setup-preferences)
(drscheme:help-desk:add-help-desk-font-prefs #t) (drscheme:help-desk:add-help-desk-font-prefs #t)
@ -275,6 +285,7 @@
warnings-panel)))) warnings-panel))))
(drscheme:debug:add-prefs-panel) (drscheme:debug:add-prefs-panel)
(install-help-browser-preference-panel) (install-help-browser-preference-panel)
(drscheme:tools:add-prefs-panel)
(drscheme:language:register-capability 'drscheme:define-popup (drscheme:language:register-capability 'drscheme:define-popup
(or/c (cons/c string? string?) false/c) (or/c (cons/c string? string?) false/c)

299
collects/drscheme/private/tools.ss
View File

@ -23,6 +23,13 @@
[prefix drscheme:modes: drscheme:modes^]) [prefix drscheme:modes: drscheme:modes^])
(export drscheme:tools^) (export drscheme:tools^)
;; An installed-tool is
;; (make-installed-tool directory-record module-spec string/#f string/#f string/#f string/#f)
(define-struct installed-tool (dir spec bitmap name url))
;; installed-tools : (list-of installed-tool)
(define installed-tools null)
;; successful-tool = (make-successful-tool module-spec ;; successful-tool = (make-successful-tool module-spec
;; (union #f (instanceof bitmap%)) ;; (union #f (instanceof bitmap%))
;; (union #f string) ;; (union #f string)
@ -48,68 +55,29 @@
;; load/invoke-all-tools : -> void ;; load/invoke-all-tools : -> void
(define (load/invoke-all-tools phase1-extras phase2-extras) (define (load/invoke-all-tools phase1-extras phase2-extras)
(rescan-installed-tools!)
(set! current-phase 'loading-tools) (set! current-phase 'loading-tools)
(load/invoke-all-tools/collections (let ([candidate-tools (filter candidate-tool? installed-tools)])
(all-tool-directories) (for-each load/invoke-tool candidate-tools)
phase1-extras (run-phases phase1-extras phase2-extras)))
phase2-extras))
;; rescan-installed-tools! : -> void
(define (rescan-installed-tools!)
(set! installed-tools (all-installed-tools)))
;; all-installed-tools : -> (list-of installed-tool)
(define (all-installed-tools)
(apply append
(map installed-tools-for-directory
(all-tool-directories))))
;; all-tool-directories : -> (list-of directory-record)
(define (all-tool-directories) (define (all-tool-directories)
(find-relevant-directories '(tools tool-icons tool-names tool-urls))) (find-relevant-directory-records '(tools tool-icons tool-names tool-urls)))
;; loads the the tools in each directory ;; installed-tools-for-directory : directory-record -> (list-of installed-tool)
;; unless PLTNOTOOLS is set, in which case it (define (installed-tools-for-directory coll-dir)
;; just runs the phases. If PLTONLYTOOL is set, (let ([table (get-info/full (directory-record-path coll-dir))])
;; it only loads tools in those collections
(define (load/invoke-all-tools/collections directories phase1-extras phase2-extras)
(cond
[(getenv "PLTNOTOOLS") (printf "PLTNOTOOLS: skipping tools\n")]
[else
(let ([onlys (getenv "PLTONLYTOOL")])
(if onlys
(let* ([allowed (let ([exp (read (open-input-string onlys))])
(cond
[(symbol? exp) (list exp)]
[(pair? exp) exp]
[else '()]))]
[filtered (filter (lambda (x)
(let-values ([(base name dir) (split-path x)])
(memq (string->symbol (path->string name))
allowed)))
directories)])
(printf "PLTONLYTOOL: only loading ~s\n" filtered)
(for-each load/invoke-tools filtered))
(for-each load/invoke-tools directories)))])
(run-phases phase1-extras phase2-extras))
;;; ;; ; ; ;;
; ; ; ;
; ; ; ;
; ;;; ;;;; ;;;; ; ;;; ; ;;; ;;; ;;; ;;; ; ;; ;;;
; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;
; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ;; ;;;;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ;;; ; ; ; ; ; ;
;;;;;; ;;; ;;; ; ;;; ; ; ;;;;; ;;; ;; ; ;;; ;; ;; ;;;
;
;; load/invoke-tools : string[collection-name] -> void
;; loads each tool in a collection
(define (load/invoke-tools coll-dir)
(let ([table (with-handlers ([(lambda (x) #f) ; exn:fail?
(lambda (x)
(show-error
(format (string-constant error-getting-info-tool)
coll-dir)
x)
#f)])
(get-info/full coll-dir))])
(when table (when table
(let* ([tools (table 'tools (lambda () null))] (let* ([tools (table 'tools (lambda () null))]
[tool-icons (table 'tool-icons (lambda () (map (lambda (x) #f) tools)))] [tool-icons (table 'tool-icons (lambda () (map (lambda (x) #f) tools)))]
@ -136,10 +104,112 @@
#f #f
'(ok stop)) '(ok stop))
(set! tool-urls (map (lambda (x) #f) tools))) (set! tool-urls (map (lambda (x) #f) tools)))
(for-each (load/invoke-tool coll-dir) tools tool-icons tool-names tool-urls))))) (map (lambda (t i n u) (make-installed-tool coll-dir t i n u))
tools tool-icons tool-names tool-urls)))))
;; load/invoke-tool : path[directory-of-collection] ;; candidate-tool? : installed-tool -> boolean
;; -> (listof string[sub-collection-name]) ;; Predicate for tools selected for execution in this
;; run of DrScheme (depending on env variables and preferences)
(define candidate-tool?
(cond
[(getenv "PLTNOTOOLS")
(printf "PLTNOTOOLS: skipping tools\n")
(lambda (it) #f)]
[(getenv "PLTONLYTOOL") =>
(lambda (onlys)
(let* ([allowed (let ([exp (read (open-input-string onlys))])
(cond
[(symbol? exp) (list exp)]
[(pair? exp) exp]
[else '()]))]
[directory-ok? (lambda (x)
(let-values ([(base name dir) (split-path x)])
(memq (string->symbol (path->string name))
allowed)))])
(printf "PLTONLYTOOL: only loading ~s\n" allowed)
(lambda (it)
(directory-ok?
(directory-record-path
(installed-tool-dir it))))))]
[else
(lambda (it)
(eq? (or (get-tool-configuration it)
(default-tool-configuration it))
'load))]))
;; get-tool-configuration : installed-tool -> symbol/#f
;; Get tool configuration preference or #f if no preference set.
(define (get-tool-configuration it)
(let ([p (assoc (installed-tool->key it) (toolspref))])
(and p (cadr p))))
;; default-tool-configuration : installed-tool -> (union 'load 'skip)
(define (default-tool-configuration it)
(preferences:get 'drscheme:default-tools-configuration))
(define toolspref
(case-lambda
[() (preferences:get 'drscheme:tools-configuration)]
[(v) (preferences:set 'drscheme:tools-configuration v)]))
(define (installed-tool->key it)
(list (directory-record-spec (installed-tool-dir it))
(installed-tool-spec it)))
(define (installed-tool-full-path it)
(apply build-path
(directory-record-path (installed-tool-dir it))
(let ([path-parts (installed-tool-spec it)])
(cond [(list? path-parts)
(append (cdr path-parts) (list (car path-parts)))]
[else (list path-parts)]))))
(define (installed-tool->module-spec it)
(let* ([dirrec (installed-tool-dir it)]
[key (directory-record-spec dirrec)]
[maj (directory-record-maj dirrec)]
[min (directory-record-min dirrec)]
[parts (let ([parts0 (installed-tool-spec it)])
(if (list? parts0)
parts0
(list parts0)))]
[file (car parts)]
[rest-parts (cdr parts)])
(case (car key)
((lib)
`(lib ,file ,@(cdr key) ,@rest-parts))
((planet)
`(planet ,file (,@(cdr key) ,maj ,min) ,@rest-parts)))))
;; installed-tool-is-loaded : installed-tool -> boolean
(define (installed-tool-is-loaded? it)
(let ([path (installed-tool-full-path it)])
(ormap (lambda (st) (equal? path (successful-tool-spec st)))
(get-successful-tools))))
;;; ;; ; ; ;;
; ; ; ;
; ; ; ;
; ;;; ;;;; ;;;; ; ;;; ; ;;; ;;; ;;; ;;; ; ;; ;;;
; ; ; ; ; ; ; ; ;; ; ; ; ; ; ; ; ; ;
; ; ; ;;;; ; ; ; ; ; ; ; ; ; ; ;; ;;;;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ;;; ; ; ; ; ; ;
;;;;;; ;;; ;;; ; ;;; ; ; ;;;;; ;;; ;; ; ;;; ;; ;; ;;;
;
;; load/invoke-tool : installed-tool -> void
(define (load/invoke-tool it)
(load/invoke-tool* (directory-record-path (installed-tool-dir it))
(installed-tool-spec it)
(installed-tool-bitmap it)
(installed-tool-name it)
(installed-tool-url it)))
;; load/invoke-tool* : path
;; (listof string[sub-collection-name])
;; (union #f (cons string[filename] (listof string[collection-name]))) ;; (union #f (cons string[filename] (listof string[collection-name])))
;; (union #f string) ;; (union #f string)
;; (union #f string) ;; (union #f string)
@ -148,8 +218,7 @@
;; `in-path' is the `coll'-relative collection-path spec for the tool module file ;; `in-path' is the `coll'-relative collection-path spec for the tool module file
;; `icon-spec' is the collection-path spec for the tool's icon, if there is one. ;; `icon-spec' is the collection-path spec for the tool's icon, if there is one.
;; `name' is the name of the tool (only used in about box) ;; `name' is the name of the tool (only used in about box)
(define (load/invoke-tool coll-dir) (define (load/invoke-tool* coll-dir in-path icon-spec name tool-url)
(lambda (in-path icon-spec name tool-url)
(let* ([icon-path (let* ([icon-path
(cond (cond
[(string? icon-spec) [(string? icon-spec)
@ -201,7 +270,7 @@
tool-url tool-url
phase1-thunk phase1-thunk
phase2-thunk) phase2-thunk)
successfully-loaded-tools))))))))) successfully-loaded-tools))))))))
;; invoke-tool : unit/sig string -> (values (-> void) (-> void)) ;; invoke-tool : unit/sig string -> (values (-> void) (-> void))
;; invokes the tools and returns the two phase thunks. ;; invokes the tools and returns the two phase thunks.
@ -362,4 +431,106 @@
(error func "can only be called in phase: ~a" (error func "can only be called in phase: ~a"
(apply string-append (apply string-append
(map (lambda (x) (format "~e " x)) (map (lambda (x) (format "~e " x))
(filter (lambda (x) x) phases))))))) (filter (lambda (x) x) phases))))))
;; Preferences GUI
(define load-action "Load the tool")
(define skip-action "Skip the tool")
(define (add-prefs-panel)
(preferences:add-panel
"Tools"
(lambda (parent)
(define main (new vertical-panel% (parent parent)))
(define advisory
(new message%
(parent main)
(label "Changes to tool configuration will take effect the next time you start DrScheme.")))
(define listing
(new list-box%
(parent main)
(label "Installed tools")
(choices null)
(callback (lambda _ (on-select-tool)))))
(define info
(new vertical-panel%
(parent main)
(style '(border))
(stretchable-height #f)))
(define location
(new text-field%
(parent info)
(label "Tool: ")))
(define location-editor (send location get-editor))
(define configuration
(new radio-box%
(label "Load the tool when DrScheme starts?")
(parent info)
(choices (list load-action skip-action #| default-action |#))
(callback (lambda _ (on-select-policy)))))
(define (populate-listing!)
(send listing clear)
(for-each
(lambda (entry+it)
(send listing append
(car entry+it)
(cdr entry+it)))
(sort (map (lambda (it) (cons (tool-list-entry it) it))
installed-tools)
(lambda (a b)
(string<? (car a) (car b))))))
(define (tool-list-entry it)
(let ([name (or (installed-tool-name it)
(format "unnamed tool ~a"
(installed-tool->module-spec it)))])
(if (installed-tool-is-loaded? it)
(string-append name " (loaded)")
name)))
(define (on-select-tool)
(let ([it (get-selected-tool)])
(send* location-editor
(begin-edit-sequence)
(lock #f)
(erase)
(insert
(if it
(format "~s" (installed-tool->module-spec it))
""))
(lock #t)
(end-edit-sequence))
(send configuration set-selection
(case (and it (get-tool-configuration it))
((load) 0)
((skip) 1)
((#f) 0))) ;; XXX (or 2, if default is an option)
(send configuration enable (and it #t))
(void)))
(define (on-select-policy)
(let ([it (get-selected-tool)]
[policy
(case (send configuration get-selection)
((0) 'load)
((1) 'skip))])
(when it
(let ([key (installed-tool->key it)])
(case policy
((load)
(toolspref (cons (list key 'load)
(let ([ts (toolspref)])
(remove (assoc key ts) ts)))))
((skip)
(toolspref (cons (list key 'skip)
(let ([ts (toolspref)])
(remove (assoc key ts) ts)))))
((#f)
(toolspref (let ([ts (toolspref)])
(remove (assoc key ts) ts))))))))
(void))
(define (get-selected-tool)
(let ([index (send listing get-selection)])
(and index (send listing get-data index))))
(populate-listing!)
(send location-editor lock #t)
main))))

33
collects/help/private/colldocs.ss
View File

@ -4,26 +4,41 @@
(lib "contract.ss")) (lib "contract.ss"))
(define (colldocs) (define (colldocs)
(let loop ([dirs (sort (map path->string (find-relevant-directories (let loop ([dirrecs
'(doc.txt) 'all-available)) (sort (find-relevant-directory-records '(doc.txt) 'all-available)
string<?)] (lambda (a b)
(bytes<? (path->bytes (directory-record-path a))
(path->bytes (directory-record-path b)))))]
[docs null] [docs null]
[names null]) [names null])
(cond (cond
[(null? dirs) (values (reverse docs) (reverse names))] [(null? dirrecs) (values (reverse docs) (reverse names))]
[else (let* ([dir (string->path (car dirs))] [else
(let* ([dirrec (car dirrecs)]
[dir (directory-record-path dirrec)]
[info-proc (get-info/full dir)]) [info-proc (get-info/full dir)])
(if info-proc (if info-proc
(let ([doc.txt-path (info-proc 'doc.txt (lambda () #f))] (let ([doc.txt-path (info-proc 'doc.txt (lambda () #f))]
[name (info-proc 'name (lambda () #f))]) [name (info-proc 'name (lambda () #f))])
(if (and (path-string? doc.txt-path) (if (and (path-string? doc.txt-path)
(string? name)) (string? name))
(loop (cdr dirs) (loop (cdr dirrecs)
(cons (list dir (string->path doc.txt-path)) (cons (list dir (string->path doc.txt-path))
docs) docs)
(cons name names)) (cons (pleasant-name name dirrec) names))
(loop (cdr dirs) docs names))) (loop (cdr dirrecs) docs names)))
(loop (cdr dirs) docs names)))]))) (loop (cdr dirrecs) docs names)))])))
(define (pleasant-name name dirrec)
(case (car (directory-record-spec dirrec))
((lib)
(format "~a collection" name))
((planet)
(format "~a package ~s"
name
`(,@(cdr (directory-record-spec dirrec))
,(directory-record-maj dirrec)
,(directory-record-min dirrec))))))
(provide/contract (provide/contract
[colldocs (-> (values (listof (list/c path? path?)) [colldocs (-> (values (listof (list/c path? path?))

4
collects/help/private/manuals.ss
View File

@ -190,13 +190,13 @@
(cadr collection-doc-file))]) (cadr collection-doc-file))])
(format "<LI> ~a" (format "<LI> ~a"
(if (file-exists? path) (if (file-exists? path)
(format "<A HREF=\"/servlets/doc-anchor.ss?file=~a&name=~a&caption=Documentation for the ~a collection\">~a collection</A>" (format "<A HREF=\"/servlets/doc-anchor.ss?file=~a&name=~a&caption=Documentation for the ~a\">~a</A>"
;; escape colons and other junk ;; escape colons and other junk
(uri-encode (path->string path)) (uri-encode (path->string path))
(uri-encode name) (uri-encode name)
(uri-encode name) (uri-encode name)
name) name)
(format "<FONT COLOR=\"RED\">~a collection: specified doc.txt file (~a) not found</FONT>" (format "<FONT COLOR=\"RED\">~a: specified doc.txt file (~a) not found</FONT>"
name path)))))) name path))))))
collections-doc-files collections-doc-files
collection-names)]) collection-names)])

2
collects/help/private/search.ss
View File

@ -68,7 +68,7 @@
(set! doc-names (append (set! doc-names (append
std-doc-names std-doc-names
(map (lambda (s) (format "the ~a collection" s)) (map (lambda (s) (format "the ~a" s))
txt-doc-names))) txt-doc-names)))
(set! doc-kinds (append (map (lambda (x) 'html) std-docs) (map (lambda (x) 'text) txt-docs))) (set! doc-kinds (append (map (lambda (x) 'html) std-docs) (map (lambda (x) 'text) txt-docs)))

89
collects/setup/getinfo.ss
View File

@ -12,17 +12,18 @@
(define info? (opt-> (symbol?) ((-> any/c)) any/c)) (define info? (opt-> (symbol?) ((-> any/c)) any/c))
(define path-or-string? (lambda (x) (or (path? x) (string? x)))) (define path-or-string? (lambda (x) (or (path? x) (string? x))))
;; in addition to infodomain/compiled/cache.ss, getinfo will look in this ;; in addition to infodomain/compiled/cache.ss, getinfo will look in this
;; file to find mappings. PLaneT uses this to put info about installed ;; file to find mappings. PLaneT uses this to put info about installed
;; planet packages. ;; planet packages.
(define user-infotable (get-planet-cache-path)) (define user-infotable (get-planet-cache-path))
;; get-info : (listof path-or-string) -> info/#f
(define (get-info coll-path) (define (get-info coll-path)
(let* ([coll-path (map (lambda (x) (if (path? x) (path->string x) x)) coll-path)] (let* ([coll-path (map (lambda (x) (if (path? x) (path->string x) x)) coll-path)]
[dir (apply collection-path coll-path)]) [dir (apply collection-path coll-path)])
(get-info/full dir))) (get-info/full dir)))
;; get-info/full : path -> info/#f
(define (get-info/full dir) (define (get-info/full dir)
(let ([file (build-path dir "info.ss")]) (let ([file (build-path dir "info.ss")])
(if (file-exists? file) (if (file-exists? file)
@ -43,16 +44,20 @@
(dynamic-require file '#%info-lookup)) (dynamic-require file '#%info-lookup))
#f))) #f)))
;; item : (list path (listof symbol) nat nat) ;; 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 ; item * listof item -> listof item (define-struct table (insert ; directory-record (listof directory-record)
ht ; hashtable[key -o> item] ; -> (listof directory-record)
paths ; listof path ht ; hashtable[symbol -o> directory-record]
paths ; (listof (cons path boolean))
)) ))
(define preferred-table #f) (define preferred-table #f)
(define all-available-table #f) (define all-available-table #f)
;; reset-relevant-directories-state! : -> void
(define (reset-relevant-directories-state!) (define (reset-relevant-directories-state!)
(set! preferred-table (set! preferred-table
(make-table (make-table
@ -61,22 +66,25 @@
[(null? l) [(null? l)
(list i)] (list i)]
[else [else
(match-let ([(_ _ my-maj my-min) i] (match-let ([($ directory-record my-maj my-min _ _ _) i]
[(_ _ their-maj their-min) (car l)]) [($ directory-record their-maj their-min _ _ _) (car l)])
(if (if (or (> my-maj their-maj)
(or (> my-maj their-maj)
(and (= my-maj their-maj) (>= my-min their-min))) (and (= my-maj their-maj) (>= my-min their-min)))
(list i) (list i)
l))])) l))]))
#f #f)) #f #f))
(set! all-available-table (make-table cons #f #f))) (set! all-available-table
(make-table cons #f #f)))
(reset-relevant-directories-state!) (reset-relevant-directories-state!)
;; populate-table : table -> void
(define (populate-table! t) (define (populate-table! t)
;; Use the colls ht because a collection might be in multiple ;; Use the colls ht because a collection might be in multiple
;; collection paths, and we only want one ;; collection paths, and we only want one
(let ([colls (make-hash-table 'equal)]) (let ([colls (make-hash-table 'equal)])
(for-each (lambda (f+root-dir) (for-each
(lambda (f+root-dir)
(let ([f (car f+root-dir)] (let ([f (car f+root-dir)]
[root-dir (cdr f+root-dir)]) [root-dir (cdr f+root-dir)])
(when (file-exists? f) (when (file-exists? f)
@ -92,13 +100,16 @@
colls colls
key key
(lambda () '()))) (lambda () '())))
(new-item (list (let ([p (bytes->path pathbytes)]) (new-item
(make-directory-record
maj
min
key
(let ([p (bytes->path pathbytes)])
(if (and (relative-path? p) root-dir) (if (and (relative-path? p) root-dir)
(build-path root-dir p) (build-path root-dir p)
p)) p))
fields fields)))
maj
min)))
(hash-table-put! colls (hash-table-put! colls
key key
((table-insert t) new-item old-items)))] ((table-insert t) new-item old-items)))]
@ -116,24 +127,32 @@
"bad info-domain cache file: ~a" "bad info-domain cache file: ~a"
f)])))))) f)]))))))
(reverse (table-paths t))) (reverse (table-paths t)))
;; For each coll, invert the mapping, adding the col name to the list for each sym: ;; For each coll, invert the mapping, adding the col name to the list
(hash-table-for-each colls ;; for each sym:
(hash-table-for-each
colls
(lambda (key vals) (lambda (key vals)
(for-each (for-each
(lambda (val) (lambda (val)
(match val (match val
[(path syms maj min) [($ directory-record maj min spec path syms)
(for-each (lambda (sym) (for-each
(lambda (sym)
(hash-table-put! (hash-table-put!
(table-ht t) (table-ht t)
sym sym
(cons path (hash-table-get (table-ht t) sym (lambda () null))))) (cons val
(hash-table-get (table-ht t) sym (lambda () null)))))
syms)] syms)]
[_ (error 'get-info [_ (error 'get-info
"Internal error: invalid info-domain value format: ~s" val)])) "Internal error: invalid info-domain value format: ~s" val)]))
vals))))) vals)))))
(define find-relevant-directories (define find-relevant-directories
(opt-lambda (syms [key 'preferred])
(map directory-record-path (find-relevant-directory-records syms key))))
(define find-relevant-directory-records
(opt-lambda (syms [key 'preferred]) (opt-lambda (syms [key 'preferred])
(define t (cond (define t (cond
[(eq? key 'preferred) preferred-table] [(eq? key 'preferred) preferred-table]
@ -145,7 +164,9 @@
;; file are relative to it. #f is used for the planet cache.ss file. ;; file are relative to it. #f is used for the planet cache.ss file.
(define search-path (define search-path
(cons (cons user-infotable #f) (cons (cons user-infotable #f)
(map (lambda (coll) (cons (build-path coll "info-domain" "compiled" "cache.ss") coll)) (map (lambda (coll)
(cons (build-path coll "info-domain" "compiled" "cache.ss")
coll))
(current-library-collection-paths)))) (current-library-collection-paths))))
(unless (equal? (table-paths t) search-path) (unless (equal? (table-paths t) search-path)
@ -153,19 +174,25 @@
(set-table-paths! t search-path) (set-table-paths! t search-path)
(populate-table! t)) (populate-table! t))
(let ([unsorted (if (= (length syms) 1) (let ([unsorted
(if (= (length syms) 1)
;; Simple case: look up in table ;; Simple case: look up in table
(hash-table-get (table-ht t) (car syms) (lambda () null)) (hash-table-get (table-ht t) (car syms) (lambda () null))
;; Use a hash table, because the same collection might work for multiple syms ;; Use a hash table, because the same collection might work
;; for multiple syms
(let ([result (make-hash-table 'equal)]) (let ([result (make-hash-table 'equal)])
(for-each (lambda (sym) (for-each
(lambda (sym)
(let ([l (hash-table-get (table-ht t) sym (lambda () null))]) (let ([l (hash-table-get (table-ht t) sym (lambda () null))])
(for-each (lambda (c) (hash-table-put! result c #t)) (for-each (lambda (c) (hash-table-put! result c #t))
l))) l)))
syms) syms)
;; Extract the relevant collections: ;; Extract the relevant collections:
(hash-table-map result (lambda (k v) k))))]) (hash-table-map result (lambda (k v) k))))])
(sort unsorted compare-directories)))) (sort unsorted
(lambda (a b)
(compare-directories (directory-record-path a)
(directory-record-path b)))))))
(define (compare-directories a b) (define (compare-directories a b)
(bytes<? (dir->sort-key a) (dir->sort-key b))) (bytes<? (dir->sort-key a) (dir->sort-key b)))
@ -185,4 +212,14 @@
(find-relevant-directories (opt-> ((listof symbol?)) (find-relevant-directories (opt-> ((listof symbol?))
((lambda (x) (or (eq? x 'preferred) ((lambda (x) (or (eq? x 'preferred)
(eq? x 'all-available)))) (eq? x 'all-available))))
(listof path?))))) (listof path?)))
(struct directory-record
([maj integer?]
[min integer?]
[spec any/c]
[path path?]
[syms (listof symbol?)]))
(find-relevant-directory-records (opt-> ((listof symbol?))
((lambda (x) (or (eq? x 'preferred)
(eq? x 'all-available))))
(listof directory-record?)))))