fix raco setup handling of info.rkt by adding a namespace argument to get-info

This commit is contained in:
Matthew Flatt 2010-05-06 07:21:54 -06:00
parent c13d65d23d
commit 6027eb9627
3 changed files with 24 additions and 17 deletions

View File

@ -984,15 +984,17 @@ An @deftech{unpackable} is one of the following:
provides functions for accessing fields in @filepath{info.rkt} provides functions for accessing fields in @filepath{info.rkt}
files.} files.}
@defproc[(get-info (collection-names (listof string?))) @defproc[(get-info [collection-names (listof string?)]
[#:namespace namespace (or/c namespace? #f) #f])
(or/c (or/c
(symbol? [(-> any)] . -> . any) (symbol? [(-> any)] . -> . any)
false/c)]{ false/c)]{
Accepts a list of strings naming a collection or sub-collection, Accepts a list of strings naming a collection or sub-collection,
and calls @racket[get-info/full] with the full path corresponding to the and calls @racket[get-info/full] with the full path corresponding to the
named collection.} named collection and the @scheme[namespace] argument.}
@defproc[(get-info/full (path path?)) @defproc[(get-info/full [path path?]
[#:namespace namespace (or/c namespace? #f) #f])
(or/c (or/c
(symbol? [(-> any)] . -> . any) (symbol? [(-> any)] . -> . any)
false/c)]{ false/c)]{
@ -1010,16 +1012,20 @@ An @deftech{unpackable} is one of the following:
case. If the name is not defined and no @racket[_thunk] is case. If the name is not defined and no @racket[_thunk] is
provided, then an exception is raised. provided, then an exception is raised.
@racket[get-info/full] returns @racket[#f] if there is The @racket[get-info/full] function returns @racket[#f] if there is
no @filepath{info.rkt} or @filepath{info.rkt} file in the directory. If there is a no @filepath{info.rkt} or @filepath{info.ss} file in the directory. If there is a
@filepath{info.rkt} file that has the wrong shape (i.e., not a module @filepath{info.rkt} (or @filepath{info.ss}) file that has the wrong shape (i.e., not a module
using @racketmodname[setup/infotab] or @racket[(lib "infotab.rkt" "setup")]), using @racketmodname[setup/infotab] or @racket[(lib "infotab.rkt" "setup")]),
or if the @filepath{info.rkt} file fails to load, then an exception or if the @filepath{info.rkt} file fails to load, then an exception
is raised. If the @filepath{info.rkt} file loaded, @racket[get-info/full] is raised. If the @filepath{info.rkt} file loaded, @racket[get-info/full]
returns the @racket[get-info] file. If the @filepath{info.rkt} file does not exist, returns the @racket[get-info] file. If the @filepath{info.rkt} file does not exist,
then @racket[get-info/full] does then @racket[get-info/full] does
the same checks for the @filepath{info.rkt} file, either raising an exception the same checks for the @filepath{info.rkt} file, either raising an exception
or returning the @racket[get-info] function from the @filepath{info.rkt} file.} or returning the @racket[get-info] function from the @filepath{info.rkt} file.
The @filepath{info.rkt} (or @filepath{info.ss}) module is loaded
into @scheme[namespace] if it is not @scheme[#f], or a private,
weakly-held namespace otherwise.}
@defproc[(find-relevant-directories @defproc[(find-relevant-directories
(syms (listof symbol?)) (syms (listof symbol?))

View File

@ -8,10 +8,11 @@
(define user-infotable (get-planet-cache-path)) (define user-infotable (get-planet-cache-path))
;; get-info : (listof path-or-string) -> info/#f ;; get-info : (listof path-or-string) -> info/#f
(define (get-info coll-path) (define (get-info coll-path #:namespace [ns #f])
(get-info/full (apply collection-path (get-info/full (apply collection-path
(map (lambda (x) (if (path? x) (path->string x) x)) (map (lambda (x) (if (path? x) (path->string x) x))
coll-path)))) coll-path))
#:namespace ns))
;; HACK: ;; HACK:
;; This require is not used. It just requires the file, since ;; This require is not used. It just requires the file, since
@ -24,11 +25,11 @@
(require (prefix-in !!!HACK!!! setup/infotab/lang/reader)) (require (prefix-in !!!HACK!!! setup/infotab/lang/reader))
;; get-info/full : path -> info/#f ;; get-info/full : path -> info/#f
(define (get-info/full dir) (define (get-info/full dir #:namespace [ns #f])
(or (get-info/full/ext dir "rkt") (or (get-info/full/ext dir "rkt" ns)
(get-info/full/ext dir "ss"))) (get-info/full/ext dir "ss" ns)))
(define (get-info/full/ext dir ext) (define (get-info/full/ext dir ext ns)
(define file (build-path dir (format "info.~a" ext))) (define file (build-path dir (format "info.~a" ext)))
(define (err fmt . args) (define (err fmt . args)
(apply error 'get-info (string-append "info file " fmt " in ~a") (apply error 'get-info (string-append "info file " fmt " in ~a")
@ -60,7 +61,7 @@
;; that is required). ;; that is required).
;; We are, however, trusting that the bytecode form of the ;; We are, however, trusting that the bytecode form of the
;; file (if any) matches the source. ;; file (if any) matches the source.
(parameterize ([current-namespace (info-namespace)]) (parameterize ([current-namespace (or ns (info-namespace))])
(dynamic-require file '#%info-lookup))] (dynamic-require file '#%info-lookup))]
[else (err "does not contain a module of the right shape")]))) [else (err "does not contain a module of the right shape")])))
@ -201,8 +202,8 @@
(provide/contract (provide/contract
(reset-relevant-directories-state! (-> any)) (reset-relevant-directories-state! (-> any))
(get-info ((listof path-or-string?) . -> . (or/c info? boolean?))) (get-info (((listof path-or-string?)) (#:namespace (or/c namespace? #f)) . ->* . (or/c info? boolean?)))
(get-info/full (path? . -> . (or/c info? boolean?))) (get-info/full ((path?) (#:namespace (or/c namespace? #f)) . ->* . (or/c info? boolean?)))
(find-relevant-directories (find-relevant-directories
(->* [(listof symbol?)] (->* [(listof symbol?)]
[(lambda (x) (memq x '(preferred all-available)))] [(lambda (x) (memq x '(preferred all-available)))]

View File

@ -41,7 +41,7 @@
[current-compile compile] [current-compile compile]
[current-load/use-compiled loader] [current-load/use-compiled loader]
[use-compiled-file-paths paths]) [use-compiled-file-paths paths])
(get-info/full path))))) (get-info/full path #:namespace ns)))))
(provide setup@) (provide setup@)