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

PR 9217

Browse Source 
svn: r8801
This commit is contained in:
Robby Findler 2008-02-25 18:19:09 +00:00
parent 8c1ff5d5e0
commit 551d980774
1 changed files with 26 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

68
collects/drscheme/private/module-overview.ss
View File

@ -196,11 +196,11 @@
(render-snips) (render-snips)
(end-edit-sequence)) (end-edit-sequence))
;; add-connection : string string boolean symbol -> void ;; add-connection : string string boolean number -> void
;; name-original and name-require and the identifiers for those paths and ;; name-original and name-require and the identifiers for those paths and
;; original-filename? and require-filename? are booleans indicating if the names ;; original-filename? and require-filename? are booleans indicating if the names
;; are filenames. ;; are filenames.
(define/public (add-connection name-original name-require path-key require-type) (define/public (add-connection name-original name-require path-key require-depth)
(unless max-lines (unless max-lines
(error 'add-connection "not in begin-adding-connections/end-adding-connections sequence")) (error 'add-connection "not in begin-adding-connections/end-adding-connections sequence"))
(let* ([original-filename? (file-exists? name-original)] (let* ([original-filename? (file-exists? name-original)]
@ -209,20 +209,15 @@
[require-snip (find/create-snip name-require require-filename?)] [require-snip (find/create-snip name-require require-filename?)]
[original-level (send original-snip get-level)] [original-level (send original-snip get-level)]
[require-level (send require-snip get-level)]) [require-level (send require-snip get-level)])
(case require-type (case require-depth
[(require) [(0)
(add-links original-snip require-snip (add-links original-snip require-snip
dark-pen light-pen dark-pen light-pen
dark-brush light-brush)] dark-brush light-brush)]
[(require-for-syntax) [else
(add-links original-snip require-snip (add-links original-snip require-snip
dark-syntax-pen light-syntax-pen dark-syntax-pen light-syntax-pen
dark-syntax-brush light-syntax-brush)] dark-syntax-brush light-syntax-brush)])
[(require-for-template)
(add-links original-snip require-snip
dark-template-pen light-template-pen
dark-template-brush light-template-brush)]
[else (error 'add-connection "unknown require-type ~s" require-type)])
(when path-key (when path-key
(send original-snip add-special-key-child path-key require-snip)) (send original-snip add-special-key-child path-key require-snip))
(if (send original-snip get-level) (if (send original-snip get-level)
@ -652,7 +647,7 @@
(send progress-frame show #t)))) (send progress-frame show #t))))
(define text/pos (define text/pos
(let ([t (make-object text%)]) (let ([t (make-object text:basic%)])
(send t load-file filename) (send t load-file filename)
(drscheme:language:make-text/pos (drscheme:language:make-text/pos
t t
@ -827,8 +822,8 @@
(let ([name-original (list-ref val 0)] (let ([name-original (list-ref val 0)]
[name-require (list-ref val 1)] [name-require (list-ref val 1)]
[path-key (list-ref val 2)] [path-key (list-ref val 2)]
[require-type (list-ref val 3)]) [require-depth (list-ref val 3)])
(send pasteboard add-connection name-original name-require path-key require-type)) (send pasteboard add-connection name-original name-require path-key require-depth))
(loop))])))) (loop))]))))
(send pasteboard end-adding-connections) (send pasteboard end-adding-connections)
@ -940,41 +935,30 @@
(unless (hash-table-get visited-hash-table module-name (λ () #f)) (unless (hash-table-get visited-hash-table module-name (λ () #f))
(async-channel-put progress-channel (format adding-file module-name)) (async-channel-put progress-channel (format adding-file module-name))
(hash-table-put! visited-hash-table module-name #t) (hash-table-put! visited-hash-table module-name #t)
(let-values ([(imports fs-imports ft-imports fl-imports) (module-compiled-imports module-code)]) (let ([import-assoc (module-compiled-imports module-code)])
(let ([requires (extract-filenames imports module-name)] (for-each
[syntax-requires (extract-filenames fs-imports module-name)] (λ (line)
[template-requires (extract-filenames ft-imports module-name)]) (let* ([level (car line)]
(for-each (λ (require) [mpis (cdr line)]
(add-connection module-name [requires (extract-filenames mpis module-name)])
(req-filename require) (for-each (λ (require)
(req-key require) (add-connection module-name
'require) (req-filename require)
(add-filename-connections (req-filename require))) (req-key require)
requires) level)
(for-each (λ (syntax-require) (add-filename-connections (req-filename require)))
(add-connection module-name requires)))
(req-filename syntax-require) import-assoc))))
(req-key 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-key require)
'require-for-template)
(add-filename-connections (req-filename require)))
template-requires)))))
;; add-connection : string string boolean symbol -> void ;; add-connection : string string boolean number -> void
;; name-original and name-require and the identifiers for those paths and ;; name-original and name-require and the identifiers for those paths and
;; original-filename? and require-filename? are booleans indicating if the names ;; original-filename? and require-filename? are booleans indicating if the names
;; are filenames. ;; are filenames.
(define (add-connection name-original name-require req-sym require-type) (define (add-connection name-original name-require req-sym require-depth)
(async-channel-put connection-channel (list name-original (async-channel-put connection-channel (list name-original
name-require name-require
req-sym req-sym
require-type))) require-depth)))
(define (extract-module-name stx) (define (extract-module-name stx)
(syntax-case stx () (syntax-case stx ()