lifted out module graph code
svn: r2116
This commit is contained in:
Robby Findler
parent
d89df834cd
commit
7a5b2fb2c5
|
|
@ -14,7 +14,16 @@
|
|||
(lib "unit.ss")
|
||||
(lib "async-channel.ss"))
|
||||
|
||||
(provide module-overview@)
|
||||
(define-struct req (filename lib?))
|
||||
;; type req = (make-req string[filename] boolean)
|
||||
|
||||
(provide module-overview@
|
||||
process-program-unit
|
||||
(struct req (filename lib?)))
|
||||
|
||||
(define adding-file (string-constant module-browser-adding-file))
|
||||
(define unknown-module-name "? unknown module name")
|
||||
|
||||
(define module-overview@
|
||||
(unit/sig drscheme:module-overview^
|
||||
(import [drscheme:frame : drscheme:frame^]
|
||||
|
|
@ -25,13 +34,10 @@
|
|||
(define filename-constant (string-constant module-browser-filename-format))
|
||||
(define font-size-gauge-label (string-constant module-browser-font-size-gauge-label))
|
||||
(define progress-label (string-constant module-browser-progress-label))
|
||||
(define adding-file (string-constant module-browser-adding-file))
|
||||
(define laying-out-graph-label (string-constant module-browser-laying-out-graph-label))
|
||||
(define open-file-format (string-constant module-browser-open-file-format))
|
||||
(define lib-paths-checkbox-constant (string-constant module-browser-show-lib-paths))
|
||||
|
||||
(define unknown-module-name "? unknown module name")
|
||||
|
||||
(preferences:set-default 'drscheme:module-overview:label-font-size 12 number?)
|
||||
(preferences:set-default 'drscheme:module-overview:window-height 500 number?)
|
||||
(preferences:set-default 'drscheme:module-overview:window-width 500 number?)
|
||||
|
|
@ -63,9 +69,6 @@
|
|||
get-lib-children
|
||||
add-lib-child))
|
||||
|
||||
(define-struct req (filename lib?))
|
||||
;; type req = (make-req string[filename] boolean)
|
||||
|
||||
;; make-module-overview-pasteboard : boolean
|
||||
;; ((union #f snip) -> void)
|
||||
;; -> (union string pasteboard)
|
||||
|
|
@ -593,141 +596,6 @@
|
|||
(make-object draw-lines-pasteboard%))
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
; ; ;; ; ; ;;; ;;; ;;; ;;; ;;; ; ;; ; ; ;;; ;; ;
|
||||
; ;; ; ;; ; ; ; ; ; ; ; ; ;; ; ;; ; ; ; ;;
|
||||
; ; ; ; ; ; ; ; ; ;; ;; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ;;;;;; ;; ;; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ;; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ;;
|
||||
; ; ;; ; ;;; ;;; ;;;; ;;; ;;; ; ;; ; ;;; ;; ;
|
||||
; ; ; ;
|
||||
; ; ; ; ;
|
||||
; ; ; ;;;;
|
||||
|
||||
|
||||
(define process-program-unit
|
||||
(unit
|
||||
(import progress-channel
|
||||
connection-channel)
|
||||
(export add-connections)
|
||||
|
||||
(define visited-hash-table (make-hash-table 'equal))
|
||||
|
||||
;; add-connections : (union syntax string[filename]) -> (union #f string)
|
||||
;; recursively adds a connections from this file and
|
||||
;; all files it requires
|
||||
;; returns a string error message if there was an error compiling
|
||||
;; the program
|
||||
(define (add-connections filename/stx)
|
||||
(cond
|
||||
[(string? filename/stx)
|
||||
(add-filename-connections filename/stx)]
|
||||
[(syntax? filename/stx)
|
||||
(add-syntax-connections filename/stx)]))
|
||||
|
||||
;; add-syntax-connections : syntax -> void
|
||||
(define (add-syntax-connections stx)
|
||||
(let ([module-codes (map compile (expand-syntax-top-level-with-compile-time-evals/flatten stx))])
|
||||
(for-each
|
||||
(λ (module-code)
|
||||
(when (compiled-module-expression? module-code)
|
||||
(let* ([name (extract-module-name stx)]
|
||||
[base
|
||||
(build-module-filename
|
||||
(if (regexp-match #rx"^," name)
|
||||
(substring name 1 (string-length name))
|
||||
(build-path (current-load-relative-directory) name)))])
|
||||
(add-module-code-connections base module-code))))
|
||||
module-codes)))
|
||||
|
||||
(define (build-module-filename str)
|
||||
(let ([try (λ (ext)
|
||||
(let ([tst (bytes->path (bytes-append (path->bytes str) ext))])
|
||||
(and (file-exists? tst)
|
||||
tst)))])
|
||||
(or (try #".ss")
|
||||
(try #".scm")
|
||||
(try #"")
|
||||
str)))
|
||||
|
||||
;; add-filename-connections : string -> void
|
||||
(define (add-filename-connections filename)
|
||||
(add-module-code-connections filename (get-module-code filename)))
|
||||
|
||||
(define (add-module-code-connections module-name module-code)
|
||||
(unless (hash-table-get visited-hash-table module-name (λ () #f))
|
||||
(async-channel-put progress-channel (format adding-file module-name))
|
||||
(hash-table-put! visited-hash-table module-name #t)
|
||||
(let-values ([(imports fs-imports ft-imports) (module-compiled-imports module-code)])
|
||||
(let ([requires (extract-filenames imports module-name)]
|
||||
[syntax-requires (extract-filenames fs-imports module-name)]
|
||||
[template-requires (extract-filenames ft-imports module-name)])
|
||||
(for-each (λ (require)
|
||||
(add-connection module-name
|
||||
(req-filename require)
|
||||
(req-lib? require)
|
||||
'require)
|
||||
(add-filename-connections (req-filename require)))
|
||||
requires)
|
||||
(for-each (λ (syntax-require)
|
||||
(add-connection module-name
|
||||
(req-filename syntax-require)
|
||||
(req-lib? syntax-require)
|
||||
'require-for-syntax)
|
||||
(add-filename-connections (req-filename syntax-require)))
|
||||
syntax-requires)
|
||||
(for-each (λ (require)
|
||||
(add-connection module-name
|
||||
(req-filename require)
|
||||
(req-lib? require)
|
||||
'require-for-template)
|
||||
(add-filename-connections (req-filename require)))
|
||||
template-requires)))))
|
||||
|
||||
;; add-connection : string string boolean symbol -> 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 is-lib? require-type)
|
||||
(async-channel-put connection-channel (list name-original
|
||||
name-require
|
||||
is-lib?
|
||||
require-type)))
|
||||
|
||||
(define (extract-module-name stx)
|
||||
(syntax-case stx ()
|
||||
[(module m-name rest ...)
|
||||
(and (eq? (syntax-e (syntax module)) 'module)
|
||||
(identifier? (syntax m-name)))
|
||||
(format "~a" (syntax-object->datum (syntax m-name)))]
|
||||
[else unknown-module-name]))
|
||||
|
||||
;; 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)
|
||||
(cons (make-req (simplify-path (expand-path (resolve-module-path-index dr base)))
|
||||
(is-lib? dr))
|
||||
(loop (cdr direct-requires)))
|
||||
(loop (cdr direct-requires))))])))
|
||||
|
||||
(define (is-lib? dr)
|
||||
(and (module-path-index? dr)
|
||||
(let-values ([(a b) (module-path-index-split dr)])
|
||||
(and (pair? a)
|
||||
(eq? 'lib (car a))))))))
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
;
|
||||
|
|
@ -841,10 +709,14 @@
|
|||
(send frame show #t)))))
|
||||
|
||||
(define (fill-pasteboard pasteboard text/pos show-status send-user-thread/eventspace)
|
||||
|
||||
(define progress-channel (make-async-channel))
|
||||
(define connection-channel (make-async-channel))
|
||||
|
||||
(define-values/invoke-unit (add-connections) process-program-unit #f progress-channel connection-channel)
|
||||
(define-values/invoke-unit (add-connections) process-program-unit
|
||||
#f
|
||||
progress-channel
|
||||
connection-channel)
|
||||
|
||||
;; =user thread=
|
||||
(define (iter sexp continue)
|
||||
|
|
@ -967,4 +839,140 @@
|
|||
(preferences:set 'drscheme:module-overview:window-width w)
|
||||
(preferences:set 'drscheme:module-overview:window-height h)
|
||||
(super on-size w h))
|
||||
(super-instantiate ()))))))
|
||||
(super-instantiate ())))))
|
||||
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
; ; ;; ; ; ;;; ;;; ;;; ;;; ;;; ; ;; ; ; ;;; ;; ;
|
||||
; ;; ; ;; ; ; ; ; ; ; ; ; ;; ; ;; ; ; ; ;;
|
||||
; ; ; ; ; ; ; ; ; ;; ;; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ;;;;;; ;; ;; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ;; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ; ;;
|
||||
; ; ;; ; ;;; ;;; ;;;; ;;; ;;; ; ;; ; ;;; ;; ;
|
||||
; ; ; ;
|
||||
; ; ; ; ;
|
||||
; ; ; ;;;;
|
||||
|
||||
|
||||
(define process-program-unit
|
||||
(unit
|
||||
(import progress-channel
|
||||
connection-channel)
|
||||
(export add-connections)
|
||||
|
||||
(define visited-hash-table (make-hash-table 'equal))
|
||||
|
||||
;; add-connections : (union syntax string[filename]) -> (union #f string)
|
||||
;; recursively adds a connections from this file and
|
||||
;; all files it requires
|
||||
;; returns a string error message if there was an error compiling
|
||||
;; the program
|
||||
(define (add-connections filename/stx)
|
||||
(cond
|
||||
[(string? filename/stx)
|
||||
(add-filename-connections filename/stx)]
|
||||
[(syntax? filename/stx)
|
||||
(add-syntax-connections filename/stx)]))
|
||||
|
||||
;; add-syntax-connections : syntax -> void
|
||||
(define (add-syntax-connections stx)
|
||||
(let ([module-codes (map compile (expand-syntax-top-level-with-compile-time-evals/flatten stx))])
|
||||
(for-each
|
||||
(λ (module-code)
|
||||
(when (compiled-module-expression? module-code)
|
||||
(let* ([name (extract-module-name stx)]
|
||||
[base
|
||||
(build-module-filename
|
||||
(if (regexp-match #rx"^," name)
|
||||
(substring name 1 (string-length name))
|
||||
(build-path (current-load-relative-directory) name)))])
|
||||
(add-module-code-connections base module-code))))
|
||||
module-codes)))
|
||||
|
||||
(define (build-module-filename str)
|
||||
(let ([try (λ (ext)
|
||||
(let ([tst (bytes->path (bytes-append (path->bytes str) ext))])
|
||||
(and (file-exists? tst)
|
||||
tst)))])
|
||||
(or (try #".ss")
|
||||
(try #".scm")
|
||||
(try #"")
|
||||
str)))
|
||||
|
||||
;; add-filename-connections : string -> void
|
||||
(define (add-filename-connections filename)
|
||||
(add-module-code-connections filename (get-module-code filename)))
|
||||
|
||||
(define (add-module-code-connections module-name module-code)
|
||||
(unless (hash-table-get visited-hash-table module-name (λ () #f))
|
||||
(async-channel-put progress-channel (format adding-file module-name))
|
||||
(hash-table-put! visited-hash-table module-name #t)
|
||||
(let-values ([(imports fs-imports ft-imports) (module-compiled-imports module-code)])
|
||||
(let ([requires (extract-filenames imports module-name)]
|
||||
[syntax-requires (extract-filenames fs-imports module-name)]
|
||||
[template-requires (extract-filenames ft-imports module-name)])
|
||||
(for-each (λ (require)
|
||||
(add-connection module-name
|
||||
(req-filename require)
|
||||
(req-lib? require)
|
||||
'require)
|
||||
(add-filename-connections (req-filename require)))
|
||||
requires)
|
||||
(for-each (λ (syntax-require)
|
||||
(add-connection module-name
|
||||
(req-filename syntax-require)
|
||||
(req-lib? syntax-require)
|
||||
'require-for-syntax)
|
||||
(add-filename-connections (req-filename syntax-require)))
|
||||
syntax-requires)
|
||||
(for-each (λ (require)
|
||||
(add-connection module-name
|
||||
(req-filename require)
|
||||
(req-lib? require)
|
||||
'require-for-template)
|
||||
(add-filename-connections (req-filename require)))
|
||||
template-requires)))))
|
||||
|
||||
;; add-connection : string string boolean symbol -> 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 is-lib? require-type)
|
||||
(async-channel-put connection-channel (list name-original
|
||||
name-require
|
||||
is-lib?
|
||||
require-type)))
|
||||
|
||||
(define (extract-module-name stx)
|
||||
(syntax-case stx ()
|
||||
[(module m-name rest ...)
|
||||
(and (eq? (syntax-e (syntax module)) 'module)
|
||||
(identifier? (syntax m-name)))
|
||||
(format "~a" (syntax-object->datum (syntax m-name)))]
|
||||
[else unknown-module-name]))
|
||||
|
||||
;; 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)
|
||||
(cons (make-req (simplify-path (expand-path (resolve-module-path-index dr base)))
|
||||
(is-lib? dr))
|
||||
(loop (cdr direct-requires)))
|
||||
(loop (cdr direct-requires))))])))
|
||||
|
||||
(define (is-lib? dr)
|
||||
(and (module-path-index? dr)
|
||||
(let-values ([(a b) (module-path-index-split dr)])
|
||||
(and (pair? a)
|
||||
(eq? 'lib (car a)))))))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user