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

pkg/path: add `path->pkg+subpath+collect'

Browse Source 
I was going to use this extension to implement `path->module-path',
but it turns out that `path->module-path' already exists and in
a form that works with packages. Still, this extension might be
useful in the future.
This commit is contained in:
Matthew Flatt 2013-07-07 21:22:58 -06:00
parent 36f7b7051e
commit 47f2742575
3 changed files with 61 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
pkgs/racket-pkgs/racket-doc/pkg/scribblings/path.scrbl
View File

@ -44,6 +44,14 @@ Like @racket[path->pkg], but returns a second value that represents
the remainder of @racket[path] within the package's directory.}
@defproc[(path->pkg+subpath+collect [path path-string?])
(values (or/c string? #f) (or/c path? 'same #f) (or/c string? #f))]{
Like @racket[path->pkg+subpath], but returns a third value for a
collection name if the package is a single-collection package,
@racket[#f] otherwise.}
@defproc[(get-pkgs-dir [scope (or/c 'installation 'user 'shared
(and/c path? complete-path?))]
[user-version string? (version)])

24
pkgs/racket-pkgs/racket-test/tests/pkg/path.rkt Normal file
View File

@ -0,0 +1,24 @@
#lang racket/base
(require pkg/path)
(module+ test
(require rackunit)
(check-equal? (path->pkg (collection-file-path "path.rkt" "tests" "pkg"))
"racket-test")
(check-equal? (call-with-values
(lambda () (path->pkg+subpath (collection-file-path "path.rkt" "tests" "pkg")))
list)
(list "racket-test" (build-path "tests" "pkg" "path.rkt")))
(check-equal? (call-with-values
(lambda () (path->pkg+subpath+collect (collection-file-path "path.rkt" "tests" "pkg")))
list)
(list "racket-test" (build-path "tests" "pkg" "path.rkt") #f))
(check-equal? (path->pkg (find-system-path 'temp-dir))
#f)
(check-equal? (call-with-values
(lambda () (path->pkg+subpath+collect (collection-file-path "serve-catalog.rkt" "distro-build")))
list)
(list "distro-build" (build-path "serve-catalog.rkt") "distro-build")))

44
racket/lib/collects/pkg/path.rkt
View File

@ -6,8 +6,9 @@
get-pkgs-dir
read-pkgs-db
read-pkg-file-hash
path->pkg
path->pkg+subpath
path->pkg)
path->pkg+subpath+collect)
(struct pkg-info (orig-pkg checksum auto?) #:prefab)
(struct sc-pkg-info pkg-info (collect) #:prefab) ; a pkg with a single collection
@ -66,7 +67,7 @@
[orig-pkg `(catalog ,(cadr (pkg-info-orig-pkg v)))])
v)))))
(define (path->pkg+subpath* who given-p cache)
(define (path->pkg+subpath+collect* who given-p cache want-collect?)
(unless (path-string? given-p)
(raise-argument-error who "path-string?" given-p))
(unless (or (not cache)
@ -85,9 +86,10 @@
(define p (explode given-p))
(define (build-path* l)
(if (null? l) 'same (apply build-path l)))
(for/fold ([pkg #f] [subpath #f]) ([scope (in-list (list* 'user 'shared
(get-pkgs-search-dirs)))]
#:when (not pkg))
(for/fold ([pkg #f] [subpath #f] [collect #f])
([scope (in-list (list* 'user 'shared
(get-pkgs-search-dirs)))]
#:when (not pkg))
(define d (or (and cache
(hash-ref cache `(dir ,scope) #f))
(let ([d (explode (get-pkgs-dir scope))])
@ -105,12 +107,17 @@
;; We assume that no one else writes there, so the
;; next path element is the package name.
(define len (length d))
(values (path-element->string (list-ref p len))
(build-path* (list-tail p (add1 len))))]
(define pkg-name (path-element->string (list-ref p len)))
(values pkg-name
(build-path* (list-tail p (add1 len)))
(and want-collect?
(let ([i (hash-ref (read-pkg-db/cached) pkg-name #f)])
(and i (sc-pkg-info? i) (sc-pkg-info-collect i)))))]
[else
;; Maybe it's a linked package
(for/fold ([pkg #f] [subpath #f]) ([(k v) (in-hash (read-pkg-db/cached))]
#:when (not pkg))
(for/fold ([pkg #f] [subpath #f] [collect #f])
([(k v) (in-hash (read-pkg-db/cached))]
#:when (not pkg))
(define orig (pkg-info-orig-pkg v))
(if (and (pair? orig)
(or (eq? 'link (car orig))
@ -118,14 +125,21 @@
(let ([orig-pkg-dir (cadr orig)])
(define e (explode orig-pkg-dir))
(if (sub-path? <= p e)
(values k (build-path* (list-tail p (length e))))
(values #f #f)))
(values #f #f)))])))
(values k
(build-path* (list-tail p (length e)))
(and (sc-pkg-info? v) (sc-pkg-info-collect v)))
(values #f #f #f)))
(values #f #f #f)))])))
(define (path->pkg+subpath+collect given-p #:cache [cache #f])
(path->pkg+subpath+collect* 'path->pkg+subpath+collect given-p cache #t))
(define (path->pkg+subpath given-p #:cache [cache #f])
(path->pkg+subpath* 'path->pkg+subpath given-p cache))
(define-values (pkg rest rest2)
(path->pkg+subpath+collect* 'path->pkg+subpath given-p cache #f))
(values pkg rest))
(define (path->pkg given-p #:cache [cache #f])
(define-values (pkg rest)
(path->pkg+subpath* path->pkg given-p cache))
(define-values (pkg rest rest2)
(path->pkg+subpath+collect* path->pkg given-p cache #f))
pkg)