diff --git a/collects/drscheme/private/module-browser.ss b/collects/drscheme/private/module-browser.ss index dde09ab38e..efcc57b997 100644 --- a/collects/drscheme/private/module-browser.ss +++ b/collects/drscheme/private/module-browser.ss @@ -9,7 +9,8 @@ mrlib/graph "drsig.ss" scheme/unit - scheme/async-channel) + scheme/async-channel + setup/private/lib-roots) (define-struct req (filename key)) ;; type req = (make-req string[filename] (union symbol #f)) @@ -196,7 +197,7 @@ (render-snips) (end-edit-sequence)) - ;; add-connection : string string symbol number -> void + ;; add-connection : string string (union symbol #f) number -> void ;; name-original and name-require and the identifiers for those paths and ;; original-filename? and require-filename? are booleans indicating if the names ;; are filenames. @@ -948,15 +949,13 @@ requires))) import-assoc)))) - ;; add-connection : string string boolean number -> void + ;; add-connection : string string (union symbol #f) number -> void ;; name-original and name-require and the identifiers for those paths and ;; original-filename? and require-filename? are booleans indicating if the names ;; are filenames. (define (add-connection name-original name-require req-sym require-depth) - (async-channel-put connection-channel (list name-original - name-require - req-sym - require-depth))) + (async-channel-put connection-channel + (list name-original name-require req-sym require-depth))) (define (extract-module-name stx) (syntax-case stx () @@ -965,30 +964,32 @@ (identifier? (syntax m-name))) (format "~a" (syntax->datum (syntax m-name)))] [else unknown-module-name])) - - ;; extract-filenames : (listof (union symbol module-path-index)) string[module-name] -> - ;; (listof req) + + ;; maps a path to the path of its "library" (see setup/private/lib-roots) + (define get-lib-root + (let ([t (make-hash)]) ; maps paths to their library roots + (lambda (path) + (hash-ref! t path (lambda () (path->library-root path)))))) + + ;; extract-filenames : + ;; (listof (union symbol module-path-index)) string[module-name] + ;; -> (listof req) (define (extract-filenames direct-requires base) - (let loop ([direct-requires direct-requires]) - (cond - [(null? direct-requires) null] - [else - - (let ([dr (car direct-requires)]) - (if (module-path-index? dr) - (let ([path (resolve-module-path-index dr base)]) - (if (path? path) - (cons (make-req (simplify-path path) (get-key dr)) - (loop (cdr direct-requires))) - (loop (cdr direct-requires)))) - (loop (cdr direct-requires))))]))) - - (define (get-key dr) + (define base-lib (get-lib-root base)) + (for*/list ([dr (in-list direct-requires)] + [path (in-value (and (module-path-index? dr) + (resolve-module-path-index dr base)))] + #:when (path? path)) + (make-req (simplify-path path) (get-key dr base-lib path)))) + + (define (get-key dr requiring-libroot required) (and (module-path-index? dr) + ;; files in the same library => return #f as if the require + ;; is a relative one, so any kind of require from the same + ;; library is always displayed (regardless of hiding planet + ;; or lib links) + (not (equal? requiring-libroot (get-lib-root required))) (let-values ([(a b) (module-path-index-split dr)]) - (cond - [(symbol? a) 'lib] - [(pair? a) - (and (symbol? (car a)) - (car a))] - [else #f]))))) + (cond [(symbol? a) 'lib] + [(pair? a) (and (symbol? (car a)) (car a))] + [else #f]))))) diff --git a/collects/setup/private/lib-roots.ss b/collects/setup/private/lib-roots.ss new file mode 100644 index 0000000000..01e907b8de --- /dev/null +++ b/collects/setup/private/lib-roots.ss @@ -0,0 +1,53 @@ +#lang scheme/base + +(require (prefix-in planet: planet/config) scheme/path scheme/list) + +;; `library-roots' is an alist of root-path, and the number of levels +;; below that which indicates a "library". This is hard-wired now to +;; the different roots, and should probably be improved at some point. +;; `path->library-root' takes in a path and returns a path to the root +;; of its library, defined by the above. (Assumes that none of the +;; roots is a subdirectory of another.) + +(provide library-roots path->library-root) + +(define library-roots + `(,@(map (lambda (p) (cons p 1)) (current-library-collection-paths)) + ,(cons (planet:CACHE-DIR) 4) + ;; add planet links, each as a root (if there is a change in + ;; the format, this will just ignore these paths, but these + ;; collections will throw an error in setup-plt) + ,@(with-handlers ([exn? (lambda (e) + (printf "WARNING: bad planet links at ~a:\n ~a" + (planet:HARD-LINK-FILE) (exn-message e)) + '())]) + (if (not (file-exists? (planet:HARD-LINK-FILE))) + '() + (with-input-from-file (planet:HARD-LINK-FILE) + (lambda () + (let loop ([r '()]) + (let ([x (read)]) + (if (eof-object? x) + (reverse r) + (let ([x (and (list? x) (= 7 (length x)) (list-ref x 4))]) + (loop (if (bytes? x) + (cons (cons (normalize-path (bytes->path x)) 0) r) + r)))))))))))) + +(define path->library-root + (let ([t #f]) + (define (init-table) + (set! t (make-hash)) + (for ([x (in-list library-roots)]) + (hash-set! t (reverse (explode-path (car x))) (cdr x)))) + (lambda (path) + (unless (complete-path? path) + (raise-type-error 'path->library-root "complete-path" path)) + (unless t (init-table)) + (let loop ([rpath (reverse (explode-path (normalize-path path)))] + [subdir '()]) + (let ([x (hash-ref t rpath #f)]) + (cond [(and x ((length subdir) . >= . x)) + (apply build-path (append (reverse rpath) (take subdir x)))] + [(or x (null? rpath)) #f] + [else (loop (cdr rpath) (cons (car rpath) subdir))])))))) diff --git a/collects/setup/private/omitted-paths.ss b/collects/setup/private/omitted-paths.ss index 6862fff231..7a249fbbc6 100644 --- a/collects/setup/private/omitted-paths.ss +++ b/collects/setup/private/omitted-paths.ss @@ -9,8 +9,7 @@ (provide omitted-paths) -(require scheme/path scheme/list "../dirs.ss" "../getinfo.ss" - (prefix-in planet: planet/config)) +(require scheme/path scheme/list "../dirs.ss" "../getinfo.ss" "lib-roots.ss") ;; An entry for each collections root that holds a hash table. The hash table ;; maps a reversed list of subpath elements to the exploded omitted-paths @@ -20,32 +19,11 @@ ;; main collection tree (it is not used there for documentation, and there is ;; at least one place where it contains code: scribble/doc). (define roots - (map - (lambda (p) - (list (explode-path p) (make-hash) - ;; don't omit "doc" in the main tree - (not (equal? (find-collects-dir) p)))) - `(,@(current-library-collection-paths) - ,(planet:CACHE-DIR) - ;; add planet links, each as a root (if there is a change in - ;; the format, this will just ignore these paths, but these - ;; collections will throw an error in setup-plt) - ,@(with-handlers ([exn? (lambda (e) - (printf "WARNING: bad planet links at ~a:\n ~a" - (planet:HARD-LINK-FILE) (exn-message e)) - '())]) - (if (not (file-exists? (planet:HARD-LINK-FILE))) - '() - (with-input-from-file (planet:HARD-LINK-FILE) - (lambda () - (let loop ([r '()]) - (let ([x (read)]) - (if (eof-object? x) - (reverse r) - (let ([x (and (list? x) (= 7 (length x)) (list-ref x 4))]) - (loop (if (bytes? x) - (cons (simplify-path (bytes->path x)) r) - r))))))))))))) + (map (lambda (p) + (list (explode-path (car p)) (make-hash) + ;; don't omit "doc" in the main tree + (not (equal? (find-collects-dir) (car p))))) + library-roots)) ;; if `x' has `y' as a prefix, return the tail, ;; eg (relative-from '(1 2 3 4) '(1 2)) => '(3 4)