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

fix show-dependencies handling of submodules

Browse Source 
original commit: d71cc04c2201844f6048533babd866f28ba0bd8b
This commit is contained in:
Ryan Culpepper 2013-02-06 17:14:54 -05:00
parent 73d6946b11
commit ff8576ba95
4 changed files with 126 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/macro-debugger/analysis/private/nom-use-alg.rkt
View File

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

76
collects/macro-debugger/analysis/private/util.rkt
View File

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

77
collects/macro-debugger/analysis/show-dependencies.rkt
View File

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

17
collects/macro-debugger/macro-debugger.scrbl
View File

@ -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,9 +548,12 @@ 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))
@ -555,7 +561,9 @@ equal to) a module in @racket[exclusions].
}
@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]