diff --git a/collects/drscheme/private/module-overview.ss b/collects/drscheme/private/module-overview.ss index 52e25e822c..72a7b6c401 100644 --- a/collects/drscheme/private/module-overview.ss +++ b/collects/drscheme/private/module-overview.ss @@ -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)))))))))