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

* Added setup/private/lib-roots as a place to decide what directory is

Browse Source 
considered a library. For now, hacked with the collects and planet
  roots (and planet links), with a fixed number of directory sublevels
  from them.
* setup/private/omitted-paths is simplified by reusing this code to
  get the roots.
* drscheme/private/module-browser uses this to always show requires
  from the same library, even for lib or planet requires.

svn: r15058
This commit is contained in:
Eli Barzilay 2009-06-02 18:48:57 +00:00
parent 02c658eaba
commit e0bab0cea2
3 changed files with 91 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
collects/drscheme/private/module-browser.ss
View File

@ -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])))))

53
collects/setup/private/lib-roots.ss Normal file
View File

@ -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))]))))))

34
collects/setup/private/omitted-paths.ss
View File

@ -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)