commit ff8576ba95891a1e26a724d7416b56ce9abb1fe9
parent 73d6946b11f298741ea0b9bd9cac14d68727c536
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Wed, 6 Feb 2013 17:14:54 -0500
fix show-dependencies handling of submodules
original commit: d71cc04c2201844f6048533babd866f28ba0bd8b
Diffstat:
4 files changed, 126 insertions(+), 46 deletions(-)
diff --git a/collects/macro-debugger/analysis/private/nom-use-alg.rkt b/collects/macro-debugger/analysis/private/nom-use-alg.rkt
@@ -99,7 +99,7 @@
(let* ([imps (map ref->imp refs)])
(refine-imps/one-require mod reqphase imps)))
-;; refine-imps/one-require : mod phase Imps -> RefineTable or #f
+;; refine-imps/one-require : mpi phase Imps -> RefineTable or #f
;; where all imps come from mod at phase
;; the result table contains new (refined) imps
(define (refine-imps/one-require mod reqphase imps)
diff --git a/collects/macro-debugger/analysis/private/util.rkt b/collects/macro-debugger/analysis/private/util.rkt
@@ -1,5 +1,6 @@
#lang racket/base
(require racket/path
+ racket/list
racket/match
syntax/modcode
syntax/modresolve
@@ -126,44 +127,81 @@
get-module-stx-exports
get-module-all-exports)
-(struct modinfo (imports var-exports stx-exports) #:prefab)
+(struct modinfo (imports var-exports stx-exports imports/r var-exports/r stx-exports/r)
+ #:prefab)
-;; cache : hash[path/symbol => modinfo]
+;; cache : hash[path/symbol/list => modinfo]
(define cache (make-hash))
+;; get-module-code* : (U path (cons path (listof symbol))) -> compiled-module
+(define (get-module-code* resolved)
+ (let* ([path (if (pair? resolved) (car resolved) resolved)]
+ [subs (if (pair? resolved) (cdr resolved) null)]
+ [code (get-module-code path)])
+ (for/fold ([code code]) ([submod-name (in-list subs)])
+ (define (choose-submod? sub)
+ (let* ([sub-name (module-compiled-name sub)])
+ (equal? (last sub-name) submod-name)))
+ (or (for/or ([sub (in-list (module-compiled-submodules code #t))])
+ (and (choose-submod? sub) sub))
+ (for/or ([sub (in-list (module-compiled-submodules code #f))])
+ (and (choose-submod? sub) sub))
+ (error 'get-module-code* "couldn't get code for: ~s" resolved)))))
+
;; get-module-info/no-cache : path -> modinfo
(define (get-module-info/no-cache resolved)
- (let ([compiled (get-module-code resolved)])
+ (let ([compiled (get-module-code* resolved)]
+ [resolved-base (if (pair? resolved) (car resolved) resolved)])
(let-values ([(imports) (module-compiled-imports compiled)]
- [(var-exports stx-exports) (module-compiled-exports compiled)])
- (parameterize ((current-directory (path-only resolved)))
+ [(var-exports stx-exports) (module-compiled-exports compiled)]
+ [(dir) (path-only (if (pair? resolved) (car resolved) resolved))])
+ (parameterize ((current-directory dir)
+ (current-load-relative-directory dir))
(force-all-mpis imports)
(force-all-mpis (cons var-exports stx-exports)))
- (modinfo imports var-exports stx-exports))))
+ (modinfo imports var-exports stx-exports
+ (resolve-all-mpis imports resolved-base)
+ (resolve-all-mpis var-exports resolved-base)
+ (resolve-all-mpis stx-exports resolved-base)))))
;; get-module-info : (or module-path module-path-index) -> modinfo
(define (get-module-info mod)
(let ([resolved (resolve mod)])
+ (when #f
+ (eprintf "fetch ~s => ~s\n"
+ (if (module-path-index? mod) (cons 'mpi (mpi->list mod)) mod)
+ resolved))
(hash-ref! cache resolved (lambda () (get-module-info/no-cache resolved)))))
-;; resolve : (or module-path module-path-index) -> path
+;; resolve : (or module-path resolved-module-path module-path-index)
+;; -> (U (U path symbol) (cons (U path symbol) (listof symbol)))
(define (resolve mod)
(cond [(module-path-index? mod)
(resolved-module-path-name (module-path-index-resolve mod))]
+ [(resolved-module-path? mod)
+ (resolved-module-path-name mod)]
[else (resolve-module-path mod #f)]))
-(define (get-module-imports path)
- (modinfo-imports (get-module-info path)))
-(define (get-module-var-exports path)
- (modinfo-var-exports (get-module-info path)))
-(define (get-module-stx-exports path)
- (modinfo-stx-exports (get-module-info path)))
-(define (get-module-exports path)
- (let ([info (get-module-info path)])
- (values (modinfo-var-exports info) (modinfo-stx-exports info))))
-(define (get-module-all-exports path)
- (append (get-module-var-exports path)
- (get-module-stx-exports path)))
+(define (get-module-imports path #:resolve? [resolve? #f])
+ ((if resolve? modinfo-imports/r modinfo-imports) (get-module-info path)))
+(define (get-module-var-exports path #:resolve? [resolve? #f])
+ ((if resolve? modinfo-var-exports/r modinfo-var-exports) (get-module-info path)))
+(define (get-module-stx-exports path #:resolve? [resolve? #f])
+ ((if resolve? modinfo-stx-exports/r modinfo-stx-exports) (get-module-info path)))
+(define (get-module-exports path #:resolve? [resolve? #f])
+ (values (get-module-var-exports path #:resolve? resolve?)
+ (get-module-stx-exports path #:resolve? resolve?)))
+(define (get-module-all-exports path #:resolve? [resolve? #f])
+ (append (get-module-var-exports path #:resolve? resolve?)
+ (get-module-stx-exports path #:resolve? resolve?)))
+
+(define (resolve-all-mpis x base)
+ (let loop ([x x])
+ (cond [(pair? x)
+ (cons (loop (car x)) (loop (cdr x)))]
+ [(module-path-index? x)
+ (resolve-module-path-index x base)]
+ [else x])))
(define (force-all-mpis x)
(let loop ([x x])
diff --git a/collects/macro-debugger/analysis/show-dependencies.rkt b/collects/macro-debugger/analysis/show-dependencies.rkt
@@ -1,14 +1,18 @@
#lang racket/base
(require racket/cmdline
+ racket/match
+ syntax/modresolve
"private/util.rkt")
(provide get-dependencies
show-dependencies
main)
-(define (get-dependencies-table #:include? include? ms)
- (define visited (make-hash)) ;; resolved-module-path => (listof mpi-list)
- (define (loop m ctx)
- (let* ([resolved (module-path-index-resolve m)]
+;; A Table is hash[resolved-module-path => (listof mpi-list)]
+
+(define (get-dependencies-table ms #:include? include?)
+ (define visited (make-hash)) ;; Table
+ (define (loop m ctx relto)
+ (let* ([resolved (resolve-module-path-index* m relto)]
[ctx (cons m ctx)]
[already-visited? (hash-ref visited resolved #f)])
(when (or include? (pair? (cdr ctx)))
@@ -16,16 +20,30 @@
(hash-set! visited resolved
(cons ctx (hash-ref visited resolved null))))
(unless already-visited?
- (unless (symbol? (resolved-module-path-name resolved))
- (let ([imports (get-module-imports m)])
- (for* ([phase+mods (in-list imports)]
- [mod (in-list (cdr phase+mods))])
- (loop mod ctx)))))))
+ (let* ([resolved-mod (resolved-module-path-name resolved)]
+ [resolved-base (if (pair? resolved-mod) (car resolved-mod) resolved-mod)])
+ (unless (symbol? resolved-base)
+ (let ([imports (get-module-imports resolved)])
+ (for* ([phase+mods (in-list imports)]
+ [mod (in-list (cdr phase+mods))])
+ (loop mod ctx resolved-base))))))))
(for ([m (in-list ms)])
- (loop (module-path-index-join m #f) null))
+ (loop (module-path-index-join m #f) null #f))
visited)
-;; table->dependencies : table -> (listof (list module-path (listof module-path)))
+;; resolve-module-path-index* : mpi file-path -> resolved-module-path
+(define (resolve-module-path-index* mpi relto)
+ (let ([v (resolve-module-path-index mpi relto)])
+ (match v
+ [(? path?) (make-resolved-module-path v)]
+ [(? symbol?) (make-resolved-module-path v)]
+ [(list* 'submod (? path? base) syms)
+ (make-resolved-module-path (cons base syms))]
+ [(list* 'submod (? symbol? base) syms)
+ (error 'resolve-module-path-index*
+ "failed to resolve submodule path base in: ~e" v)])))
+
+;; table->dependencies : Table -> (listof (list module-path (listof module-path)))
(define (table->dependencies visited)
(let* ([unsorted
(for/list ([(key mpi-lists) (in-hash visited)])
@@ -50,22 +68,35 @@
;; obviously, we don't care that much about performance in this case
(string<? (format "~s" A) (format "~s" B))]))
-;; get-dependencies : module-path ... #:excludse (listof module-path)
+;; get-dependencies : module-path ... #:exclude (listof module-path)
;; -> (listof (list module-path (listof module-path)))
-(define (get-dependencies #:exclude [exclusions null]
+(define (get-dependencies #:exclude [exclude null]
+ #:exclude-deps [exclude-deps null]
. module-paths)
(let* ([table
(get-dependencies-table #:include? #f module-paths)]
[exclude-table
- (get-dependencies-table #:include? #t exclusions)])
+ (get-dependencies-table #:include? #t exclude)]
+ [exclude-deps-roots
+ (for/hash ([mod (in-list exclude-deps)])
+ (values (resolve-module-path-index* (module-path-index-join mod #f) #f) #t))]
+ [exclude-deps-table
+ (get-dependencies-table #:include? #f exclude-deps)])
(for ([key (in-hash-keys exclude-table)])
(hash-remove! table key))
+ (for ([key (in-hash-keys exclude-deps-table)])
+ (unless (hash-ref exclude-deps-roots key #f)
+ (hash-remove! table key)))
(table->dependencies table)))
-(define (show-dependencies #:exclude [exclusions null]
+(define (show-dependencies #:exclude [exclude null]
+ #:exclude-deps [exclude-deps null]
#:show-context? [context? #f]
. module-paths)
- (for ([dep (in-list (apply get-dependencies #:exclude exclusions module-paths))])
+ (for ([dep (in-list (apply get-dependencies
+ #:exclude exclude
+ #:exclude-deps exclude-deps
+ module-paths))])
(let ([mod (car dep)]
[direct-requirers (cadr dep)])
(printf "~s" mod)
@@ -78,7 +109,8 @@
(define (main . argv)
(define mode 'auto)
(define context? #f)
- (define exclusions null)
+ (define excludes null)
+ (define exclude-deps null)
(command-line
#:argv argv
#:once-each
@@ -88,10 +120,12 @@
(set! mode 'file)]
[("-m" "--module-path") "Interpret arguments as module-paths"
(set! mode 'module-path)]
- [("-x" "--exclude") exclude "Exclude modules reachable from <exclude>"
- (set! exclusions (cons exclude exclusions))]
+ [("-x" "--exclude") mod "Exclude <mod> and its dependencies"
+ (set! excludes (cons mod excludes))]
+ [("-X" "--exclude-deps") mod "Exclude the dependencies of <mod> (but not <mod> itself)"
+ (set! exclude-deps (cons mod exclude-deps))]
[("-b") "Same as --exclude racket/base"
- (set! exclusions (cons 'racket/base exclusions))]
+ (set! excludes (cons 'racket/base excludes))]
#:args module-path
(let ()
(define (->modpath x)
@@ -106,7 +140,8 @@
(read (open-input-string x))))]
[else x]))
(apply show-dependencies
- #:exclude (map ->modpath exclusions)
+ #:exclude (map ->modpath excludes)
+ #:exclude-deps (map ->modpath exclude-deps)
#:show-context? context?
(map ->modpath module-path)))))
diff --git a/collects/macro-debugger/macro-debugger.scrbl b/collects/macro-debugger/macro-debugger.scrbl
@@ -5,6 +5,7 @@
scribble/eval
(for-label racket/base
racket/contract/base
+ racket/lazy-require
racket/runtime-path
macro-debugger/expand
macro-debugger/emit
@@ -519,7 +520,9 @@ is interpreted as a module path. See @racket[show-dependencies] for a
description of the output format.
@defproc[(show-dependencies [root module-path?] ...
- [#:exclude exclusions
+ [#:exclude exclude
+ (listof module-path?) null]
+ [#:exclude-deps exclude-deps
(listof module-path?) null]
[#:show-context? show-context? boolean? #f])
void?]{
@@ -528,7 +531,7 @@ Computes the set of modules transitively required by the @racket[root]
module(s). A @racket[root] module is included in the output
only if it is a dependency of another @racket[root] module. The
computed dependencies do not include modules reached through
-@racket[dynamic-require] or referenced by
+@racket[dynamic-require] or @racket[lazy-require] or referenced by
@racket[define-runtime-module-path-index] but do include modules
referenced by @racket[define-runtime-module-path] (since that
implicitly creates a @racket[for-label] dependency).
@@ -545,17 +548,22 @@ require @racket[_dep-module].
}
The dependencies are trimmed by removing any module reachable from (or
-equal to) a module in @racket[exclusions].
+equal to) a module in @racket[exclude] as well as any module
+reachable from (but not equal to) a module in @racket[exclude-deps].
@examples[#:eval the-eval
(show-dependencies 'openssl
+ #:exclude (list 'racket))
+(show-dependencies 'openssl
#:show-context? #t
#:exclude (list 'racket))
]
}
@defproc[(get-dependencies [root module-path?] ...
- [#:exclude exclusions
+ [#:exclude exclude
+ (listof module-path?) null]
+ [#:exclude-deps exclude-deps
(listof module-path?) null])
(listof (list module-path? (listof module-path?)))]{
@@ -568,5 +576,4 @@ module path and the module paths of its immediate dependents.
]
}
-
@close-eval[the-eval]
