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

add support for collection roots to the collection links file

Browse Source
This commit is contained in:
Matthew Flatt 2011-08-24 16:25:09 -06:00
parent 8f0487d8e4
commit 84e3ab2a20
8 changed files with 656 additions and 556 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
collects/scribblings/raco/link.scrbl
View File

@ -58,7 +58,15 @@ Full command-line options:
@DFlag{remove} flag is also used, only links with a collection @DFlag{remove} flag is also used, only links with a collection
name matching @nonterm{name} are removed, and if no directory name matching @nonterm{name} are removed, and if no directory
arguments are provided, all links with a match to arguments are provided, all links with a match to
@nonterm{name} are removed.} @nonterm{name} are removed. This flag is mutually exclusive with
@Flag{d} and @DFlag{root}.}
@item{@Flag{d} or @DFlag{root} --- Treats each directory as a
collection root that contains collection directories, instead of
a directory for a specific collection. When the @Flag{r} or
@DFlag{remove} flag is also used, only collection-root links
that match a directory are removed. This flag is mutually
exclusive with @Flag{n} and @DFlag{name}.}
@item{@Flag{x} @nonterm{regexp} or @DFlag{version-regexp} @item{@Flag{x} @nonterm{regexp} or @DFlag{version-regexp}
@nonterm{regexp} --- Sets a version regexp that limits the link @nonterm{regexp} --- Sets a version regexp that limits the link
@ -106,6 +114,7 @@ Full command-line options:
[#:user? user? #t] [#:user? user? #t]
[#:file file (or/c path-string? #f) #f] [#:file file (or/c path-string? #f) #f]
[#:name name (or/c string? #f) #f] [#:name name (or/c string? #f) #f]
[#:root? root? any/c #f]
[#:version-regexp version-regexp (or/c regexp? #f) #f] [#:version-regexp version-regexp (or/c regexp? #f) #f]
[#:error error-proc (symbol? string? any/c ... . -> . any) error] [#:error error-proc (symbol? string? any/c ... . -> . any) error]
[#:remove? remove? any/c #f] [#:remove? remove? any/c #f]
@ -122,8 +131,10 @@ reference-doc]{collection links file} if @racket[user?] is false.
The @racket[error-proc] argument is called to raise exceptions that The @racket[error-proc] argument is called to raise exceptions that
would be fatal to the @exec{raco link} command. would be fatal to the @exec{raco link} command.
If @racket[remove?] is false, the result is a list of top-level If @racket[remove?] is true, the result is a list of entries that were
collection names (as strings) that are mapped by @racket[file] and removed from the file. If @racket[remove?] is false but
that apply to the running version of Racket. If @racket[remove?] is @racket[root?] is true, the result is a list of paths for collection
true, the result is a list of entries that were removed from the file.} roots. If @racket[remove?] and @racket[root?] are both false, the
result is a list of top-level collection names (as strings) that are
mapped by @racket[file] and that apply to the running version of
Racket.}

28
collects/scribblings/reference/collects.scrbl
View File

@ -185,21 +185,23 @@ the file is re-read if its timestamp changes.
Each @tech{collection links file} is @racket[read] with default reader Each @tech{collection links file} is @racket[read] with default reader
parameter settings to obtain a list. Every element of the list must be parameter settings to obtain a list. Every element of the list must be
a link specification with either the form @racket[(_string _path)] or a link specification with one of the forms @racket[(list _string
the form @racket[(_string _path _regexp)]. In both cases, the _path)], @racket[(list _string _path _regexp)], @racket[(list 'root
@racket[_string] names a top-level @tech{collection}, and _path)], or @racket[(list 'root _regexp)]. A @racket[_string] names a
@racket[_path] is a path that can be used as the collection's path top-level @tech{collection}, in which case @racket[_path] is a path
(directly, as opposed to a subdirectory of @racket[_path] named by that can be used as the collection's path (directly, as opposed to a
@racket[_string]). If @racket[_path] is a relative path, it is subdirectory of @racket[_path] named by @racket[_string]). A
relative to the directory containing the @tech{collection links @racket['root] entry, in contrast, acts like an path in
file}. If @racket[_regexp] is specified in a link, then the link is @racket[(current-library-collection-paths)]. If @racket[_path] is a
used only if @racket[(regexp-match? _regexp (version))] produces a relative path, it is relative to the directory containing the
true result. @tech{collection links file}. If @racket[_regexp] is specified in a
link, then the link is used only if @racket[(regexp-match? _regexp
(version))] produces a true result.
A single top-level collection can have multiple links in a A single top-level collection can have multiple links in a
@tech{collection links file}. The corresponding paths are effectively @tech{collection links file}, and any number of @racket['root] entries
spliced together, since the paths are tried in order to locate a file can appear. The corresponding paths are effectively spliced together,
or sub-collection. since the paths are tried in order to locate a file or sub-collection.
The @exec{raco link} command-link tool can display, install, and The @exec{raco link} command-link tool can display, install, and
remove links in the @tech{collection links file}. See @secref[#:doc remove links in the @tech{collection links file}. See @secref[#:doc

6
collects/setup/commands/link.rkt
View File

@ -5,6 +5,7 @@
(define link-file (make-parameter #f)) (define link-file (make-parameter #f))
(define link-name (make-parameter #f)) (define link-name (make-parameter #f))
(define root-mode (make-parameter #f))
(define link-version (make-parameter #f)) (define link-version (make-parameter #f))
(define remove-mode (make-parameter #f)) (define remove-mode (make-parameter #f))
(define repair-mode (make-parameter #f)) (define repair-mode (make-parameter #f))
@ -20,8 +21,12 @@
#:once-each #:once-each
[("-l" "--list") "Show the link table (after changes)" [("-l" "--list") "Show the link table (after changes)"
(show-mode #t)] (show-mode #t)]
#:once-any
[("-n" "--name") name "Collection name to add (single <dir>) or remove" [("-n" "--name") name "Collection name to add (single <dir>) or remove"
(link-name name)] (link-name name)]
[("-d" "--root") "Treat <dir> as a collection root"
(root-mode #t)]
#:once-each
[("-x" "--version-regexp") regexp "Set the version pregexp" [("-x" "--version-regexp") regexp "Set the version pregexp"
(with-handlers ([exn:fail:contract? (lambda (exn) (with-handlers ([exn:fail:contract? (lambda (exn)
(raise-user-error link-symbol (raise-user-error link-symbol
@ -62,6 +67,7 @@
(define (go user?) (define (go user?)
(apply links (apply links
dirs dirs
#:root? (root-mode)
#:user? user? #:user? user?
#:file (link-file) #:file (link-file)
#:name (link-name) #:name (link-name)

53
collects/setup/link.rkt
View File

@ -10,6 +10,7 @@
#:file [in-file #f] #:file [in-file #f]
#:name [name #f] #:name [name #f]
#:version-regexp [version-regexp #f] #:version-regexp [version-regexp #f]
#:root? [root? #f]
#:remove? [remove? #f] #:remove? [remove? #f]
#:show? [show? #f] #:show? [show? #f]
#:repair? [repair? #f] #:repair? [repair? #f]
@ -56,8 +57,9 @@
(= 3 (length e)))) (= 3 (length e))))
(content-error "entry is a not a 2- or 3-element list: " e)) (content-error "entry is a not a 2- or 3-element list: " e))
#:when #:when
(or (string? (car e)) (or (or (string? (car e))
(content-error "entry's first element is not a string: " e)) (eq? 'root (car e)))
(content-error "entry's first element is not a string or 'root: " e))
#:when #:when
(or (path-string? (cadr e)) (or (path-string? (cadr e))
(content-error "entry's second element is not a path string: " e)) (content-error "entry's second element is not a path string: " e))
@ -100,24 +102,29 @@
(find-relative-path file-dir (find-relative-path file-dir
(simplify-path (simplify-path
(path->complete-path d))))] (path->complete-path d))))]
[a-name (and d [a-name (if root?
(or name 'root
(let-values ([(base name dir?) (split-path dp)]) (and d
(path-element->string name))))] (or name
(let-values ([(base name dir?) (split-path dp)])
(path-element->string name)))))]
[rx version-regexp] [rx version-regexp]
[d (and dp (path->string dp))]) [d (and dp (path->string dp))]
[sd (and d (simplify d))])
(unless remove? (unless remove?
(unless (directory-exists? dp) (unless (directory-exists? sd)
(error 'links (error 'links
"no such directory for link: ~a" "no such directory for link: ~a"
dp))) sd)))
(if remove? (if remove?
(filter (lambda (e) (filter (lambda (e)
(or (and d (or (and d
(not (equal? (simplify (cadr e)) (not (equal? (simplify (cadr e))
(simplify d)))) sd)))
(and name (and name
(not (equal? (car e) name))) (not (equal? (car e) name)))
(and root?
(not (eq? (car e) 'root)))
(and version-regexp (and version-regexp
(pair? (cddr e)) (pair? (cddr e))
(not (equal? (caddr e) version-regexp))))) (not (equal? (caddr e) version-regexp)))))
@ -159,7 +166,10 @@
(when show? (when show?
(for ([e (in-list new-table)]) (for ([e (in-list new-table)])
(printf " collection: ~s path: ~s~a\n" (printf " ~a~s path: ~s~a\n"
(if (eq? (car e) 'root)
""
"collection: ")
(car e) (car e)
(path->string (simplify (cadr e))) (path->string (simplify (cadr e)))
(if (null? (cddr e)) (if (null? (cddr e))
@ -170,10 +180,17 @@
(if remove? (if remove?
;; return list of removed entries: ;; return list of removed entries:
(filter (lambda (e) (not (member e new-table))) table) (filter (lambda (e) (not (member e new-table))) table)
;; Return list of collections mapped for this version: (if root?
(let ([ht (make-hash)]) ;; Return root paths:
(for ([e (in-list new-table)]) (for/list ([e (in-list new-table)]
(when (or (null? (cddr e)) #:when (eq? 'root (car e)))
(regexp-match? (caddr e) (version))) (simplify (cadr e)))
(hash-set! ht (car e) #t))) ;; Return list of collections mapped for this version:
(hash-map ht (lambda (k e) k))))) (let ([ht (make-hash)])
(for ([e (in-list new-table)])
(when (and (string? (car e))
(or (null? (cddr e))
(regexp-match? (caddr e) (version))))
(hash-set! ht (car e) #t)))
(hash-map ht (lambda (k e) k))))))

42
collects/setup/setup-unit.rkt
View File

@ -283,31 +283,41 @@
(define all-collections (define all-collections
(let ([ht (make-hash)]) (let ([ht (make-hash)])
(define (maybe collection ->cc)
(hash-ref ht collection
(lambda ()
(let ([cc (->cc collection)])
(when cc (hash-set! ht collection cc))))))
(for ([cp (current-library-collection-paths)] (for ([cp (current-library-collection-paths)]
#:when (directory-exists? cp) #:when (directory-exists? cp)
[collection (directory-list cp)] [collection (directory-list cp)]
#:when (directory-exists? (build-path cp collection))) #:when (directory-exists? (build-path cp collection)))
(hash-ref ht collection (maybe (list collection) collection->cc))
(lambda ()
(let ([cc (collection->cc (list collection))])
(when cc (hash-set! ht collection cc))))))
(let ([main-collects (find-collects-dir)]) (let ([main-collects (find-collects-dir)])
(define (->cc col)
(collection->cc col
#:info-root main-collects
#:info-path-mode 'abs-in-relative
#:omit-root 'dir))
(for ([c (in-list (links #:user? #f))]) (for ([c (in-list (links #:user? #f))])
(let* ([c (string->path c)] (maybe (list (string->path c)) ->cc))
[cc (collection->cc (list c) (for ([cp (in-list (links #:root? #t #:user? #f))]
#:info-root main-collects #:when (directory-exists? cp)
#:info-path-mode 'abs-in-relative [collection (directory-list cp)])
#:omit-root 'dir)]) (maybe (list collection) ->cc)))
(when cc (hash-set! ht c cc)))))
(when (make-user) (when (make-user)
(let ([user-collects (find-user-collects-dir)]) (let ([user-collects (find-user-collects-dir)])
(define (->cc col)
(collection->cc col
#:info-root user-collects
#:info-path-mode 'abs-in-relative
#:omit-root 'dir))
(for ([c (in-list (links))]) (for ([c (in-list (links))])
(let* ([c (string->path c)] (maybe (list (string->path c)) ->cc))
[cc (collection->cc (list c) (for ([cp (in-list (links #:root? #t))]
#:info-root user-collects #:when (directory-exists? cp)
#:info-path-mode 'abs-in-relative [collection (directory-list cp)])
#:omit-root 'dir)]) (maybe (list collection) ->cc))))
(when cc (hash-set! ht c cc))))))
(hash-map ht (lambda (k v) v)))) (hash-map ht (lambda (k v) v))))
;; Close over sub-collections ;; Close over sub-collections

986
src/racket/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

31
src/racket/src/startup.inc
View File

@ -311,7 +311,8 @@
"(when(log-level? l 'error)" "(when(log-level? l 'error)"
"(log-message l 'error " "(log-message l 'error "
"(format" "(format"
" \"error reading linked collections: ~a\"" " \"error reading collection links file ~s: ~a\""
"(if user? user-links-path links-path)"
"(exn-message exn))" "(exn-message exn))"
"(current-continuation-marks))))" "(current-continuation-marks))))"
"(when ts" "(when ts"
@ -364,7 +365,8 @@
"(and(list? p)" "(and(list? p)"
"(or(= 2(length p))" "(or(= 2(length p))"
"(= 3(length p)))" "(= 3(length p)))"
"(string?(car p))" "(or(string?(car p))"
"(eq? 'root(car p)))"
"(path-string?(cadr p))" "(path-string?(cadr p))"
"(or(null?(cddr p))" "(or(null?(cddr p))"
"(regexp?(caddr p)))))" "(regexp?(caddr p)))))"
@ -379,10 +381,23 @@
"(lambda(p)" "(lambda(p)"
"(when(or(null?(cddr p))" "(when(or(null?(cddr p))"
"(regexp-match?(caddr p)(version)))" "(regexp-match?(caddr p)(version)))"
"(let((dir(simplify-path"
"(path->complete-path(cadr p) dir))))"
"(if(symbol?(car p))"
"(begin"
"(unless(hash-ref ht #f #f)"
"(hash-set! ht #f null))"
"(hash-for-each"
" ht"
"(lambda(k v)"
"(hash-set! ht k(cons dir v)))))"
"(let((s(string->symbol(car p))))" "(let((s(string->symbol(car p))))"
"(hash-set! ht s(cons(box(path->complete-path(cadr p) dir))" "(hash-set! ht s(cons(box dir)"
"(hash-ref ht s null))))))" "(hash-ref ht s null))))))))"
" v)" " v)"
"(hash-for-each"
" ht"
"(lambda(k v)(hash-set! ht k(reverse v))))"
"(if user?" "(if user?"
"(begin" "(begin"
"(set! user-links-cache ht)" "(set! user-links-cache ht)"
@ -422,10 +437,14 @@
" collection))))" " collection))))"
"(append" "(append"
"(if(use-user-specific-search-paths)" "(if(use-user-specific-search-paths)"
"(hash-ref(get-linked-collections #t) sym null)" "(let((ht(get-linked-collections #t)))"
"(or(hash-ref ht sym #f)"
"(hash-ref ht #f null)))"
" null)" " null)"
"(if links-path" "(if links-path"
"(hash-ref(get-linked-collections #f) sym null)" "(let((ht(get-linked-collections #f)))"
"(or(hash-ref ht sym #f)"
"(hash-ref ht #f null)))"
" null)" " null)"
"(current-library-collection-paths)))))" "(current-library-collection-paths)))))"
"(define-values(*build-path-rep)" "(define-values(*build-path-rep)"

43
src/racket/src/startup.rktl
View File

@ -379,7 +379,8 @@
(when (log-level? l 'error) (when (log-level? l 'error)
(log-message l 'error (log-message l 'error
(format (format
"error reading linked collections: ~a" "error reading collection links file ~s: ~a"
(if user? user-links-path links-path)
(exn-message exn)) (exn-message exn))
(current-continuation-marks)))) (current-continuation-marks))))
(when ts (when ts
@ -432,7 +433,8 @@
(and (list? p) (and (list? p)
(or (= 2 (length p)) (or (= 2 (length p))
(= 3 (length p))) (= 3 (length p)))
(string? (car p)) (or (string? (car p))
(eq? 'root (car p)))
(path-string? (cadr p)) (path-string? (cadr p))
(or (null? (cddr p)) (or (null? (cddr p))
(regexp? (caddr p))))) (regexp? (caddr p)))))
@ -447,10 +449,29 @@
(lambda (p) (lambda (p)
(when (or (null? (cddr p)) (when (or (null? (cddr p))
(regexp-match? (caddr p) (version))) (regexp-match? (caddr p) (version)))
(let ([s (string->symbol (car p))]) (let ([dir (simplify-path
(hash-set! ht s (cons (box (path->complete-path (cadr p) dir)) (path->complete-path (cadr p) dir))])
(hash-ref ht s null)))))) (if (symbol? (car p))
;; add to every table element (to keep
;; the choices in order); need a better
;; data structure
(begin
(unless (hash-ref ht #f #f)
(hash-set! ht #f null))
(hash-for-each
ht
(lambda (k v)
(hash-set! ht k (cons dir v)))))
;; single collection:
(let ([s (string->symbol (car p))])
(hash-set! ht s (cons (box dir)
(hash-ref ht s null))))))))
v) v)
;; reverse all lists:
(hash-for-each
ht
(lambda (k v) (hash-set! ht k (reverse v))))
;; save table & timestamp:
(if user? (if user?
(begin (begin
(set! user-links-cache ht) (set! user-links-cache ht)
@ -492,13 +513,17 @@
(path->string collection) (path->string collection)
collection))]) collection))])
(append (append
;; list of (box path)s: ;; list of paths and (box path)s:
(if (use-user-specific-search-paths) (if (use-user-specific-search-paths)
(hash-ref (get-linked-collections #t) sym null) (let ([ht (get-linked-collections #t)])
(or (hash-ref ht sym #f)
(hash-ref ht #f null)))
null) null)
;; list of (box path)s: ;; list of paths and (box path)s:
(if links-path (if links-path
(hash-ref (get-linked-collections #f) sym null) (let ([ht (get-linked-collections #f)])
(or (hash-ref ht sym #f)
(hash-ref ht #f null)))
null) null)
;; list of paths: ;; list of paths:
(current-library-collection-paths)))]) (current-library-collection-paths)))])