diff --git a/collects/drracket/private/drsig.rkt b/collects/drracket/private/drsig.rkt index b2f3dda7df..a3e4ea0ee0 100644 --- a/collects/drracket/private/drsig.rkt +++ b/collects/drracket/private/drsig.rkt @@ -322,6 +322,7 @@ ()) (define-signature drracket:module-overview^ extends drracket:module-overview-cm^ (module-overview + module-overview/file make-module-overview-pasteboard fill-pasteboard)) diff --git a/collects/drracket/private/module-browser.rkt b/collects/drracket/private/module-browser.rkt index 5da7ae9c2c..00b2078f52 100644 --- a/collects/drracket/private/module-browser.rkt +++ b/collects/drracket/private/module-browser.rkt @@ -62,7 +62,8 @@ get-word get-lines is-special-key-child? - add-special-key-child)) + add-special-key-child + set-found!)) ;; make-module-overview-pasteboard : boolean ;; ((union #f snip) -> void) @@ -76,7 +77,10 @@ ;; snip-table : hash-table[sym -o> snip] (define snip-table (make-hash)) (define label-font (find-label-font (preferences:get 'drracket:module-overview:label-font-size))) - (define text-color (make-object color% "blue")) + (define text-color "blue") + + (define search-result-text-color "white") + (define search-result-background "forestgreen") (define dark-syntax-pen (send the-pen-list find-or-create-pen "darkorchid" 1 'solid)) (define dark-syntax-brush (send the-brush-list find-or-create-brush "darkorchid" 'solid)) @@ -512,6 +516,8 @@ lines pb) + (inherit get-admin) + (define require-phases '()) (define/public (add-require-phase d) (unless (member d require-phases) @@ -541,8 +547,8 @@ "salmon" 'solid)))) - (field (snip-width 0) - (snip-height 0)) + (define snip-width 0) + (define snip-height 0) (define/override (get-extent dc x y wb hb descent space lspace rspace) (cond @@ -551,8 +557,8 @@ (set! snip-height 15)] [else (let-values ([(w h a d) (send dc get-text-extent (name->label) label-font)]) - (set! snip-width (+ w 4)) - (set! snip-height (+ h 4)))]) + (set! snip-width (+ w 5)) + (set! snip-height (+ h 5)))]) (set-box/f wb snip-width) (set-box/f hb snip-height) (set-box/f descent 0) @@ -560,20 +566,36 @@ (set-box/f lspace 0) (set-box/f rspace 0)) + (define/public (set-found! fh?) + (unless (eq? (and fh? #t) found-highlight?) + (set! found-highlight? (and fh? #t)) + (let ([admin (get-admin)]) + (when admin + (send admin needs-update this 0 0 snip-width snip-height))))) + (define found-highlight? #f) + (define/override (draw dc x y left top right bottom dx dy draw-caret) (let ([old-font (send dc get-font)] [old-text-foreground (send dc get-text-foreground)] - [old-brush (send dc get-brush)]) + [old-brush (send dc get-brush)] + [old-pen (send dc get-pen)]) (send dc set-font label-font) - (when lines-brush - (send dc set-brush lines-brush)) + (cond + [found-highlight? + (send dc set-brush search-result-background 'solid)] + [lines-brush + (send dc set-brush lines-brush)]) (when (and (or (<= left x right) (<= left (+ x snip-width) right)) (or (<= top y bottom) (<= top (+ y snip-height) bottom))) (send dc draw-rectangle x y snip-width snip-height) - (send dc set-text-foreground text-color) + (send dc set-text-foreground (send the-color-database find-color + (if found-highlight? + search-result-text-color + text-color))) (send dc draw-text (name->label) (+ x 2) (+ y 2))) + (send dc set-pen old-pen) (send dc set-brush old-brush) (send dc set-text-foreground old-text-foreground) (send dc set-font old-font))) @@ -626,7 +648,7 @@ (define draw-lines-pasteboard% (module-overview-pasteboard-mixin (graph-pasteboard-mixin pasteboard:basic%))) - (make-object draw-lines-pasteboard%)) + (new draw-lines-pasteboard% [cache-arrow-drawing? #t])) ; @@ -648,7 +670,8 @@ (define (module-overview/file filename parent) - (define progress-frame (parameterize ([current-eventspace (make-eventspace)]) + (define progress-eventspace (make-eventspace)) + (define progress-frame (parameterize ([current-eventspace progress-eventspace]) (instantiate frame% () (parent parent) (label progress-label) @@ -661,8 +684,11 @@ (define thd (thread (λ () - (sleep 3) - (send progress-frame show #t)))) + (sleep 2) + (parameterize ([current-eventspace progress-eventspace]) + (queue-callback + (λ () + (send progress-frame show #t))))))) (define text/pos (let ([t (make-object text:basic%)]) @@ -675,7 +701,10 @@ (define update-label void) (define (show-status str) - (send progress-message set-label str)) + (parameterize ([current-eventspace progress-eventspace]) + (queue-callback + (λ () + (send progress-message set-label str))))) (define pasteboard (make-module-overview-pasteboard #f @@ -683,7 +712,10 @@ (let ([success? (fill-pasteboard pasteboard text/pos show-status void)]) (kill-thread thd) - (send progress-frame show #f) + (parameterize ([current-eventspace progress-eventspace]) + (queue-callback + (λ () + (send progress-frame show #f)))) (when success? (let () (define frame (instantiate overview-frame% () @@ -751,6 +783,23 @@ (define ec (make-object canvas:basic% vp pasteboard)) + (define search-tf + (new text-field% + [label (string-constant module-browser-highlight)] + [parent vp] + [callback + (λ (tf evt) + (send pasteboard begin-edit-sequence) + (define val (send tf get-value)) + (define reg (and (not (string=? val "")) + (regexp (regexp-quote (send tf get-value))))) + (let loop ([snip (send pasteboard find-first-snip)]) + (when snip + (when (is-a? snip boxed-word-snip<%>) + (send snip set-found! (and reg (regexp-match reg (path->string (send snip get-filename)))))) + (loop (send snip next)))) + (send pasteboard end-edit-sequence))])) + (send lib-paths-checkbox set-value (not (memq 'lib (preferences:get 'drracket:module-browser:hide-paths)))) (set! update-label (λ (s) diff --git a/collects/drracket/private/unit.rkt b/collects/drracket/private/unit.rkt index 45cfe83ddf..59885bd55e 100644 --- a/collects/drracket/private/unit.rkt +++ b/collects/drracket/private/unit.rkt @@ -3722,6 +3722,21 @@ module browser threading seems wrong. (string-constant module-browser...) language-specific-menu (λ (x y) (drracket:module-overview:module-overview this))) + (new menu:can-restore-menu-item% + [label (format (string-constant module-browser-in-file) + (send definitions-text get-filename))] + [parent language-specific-menu] + [demand-callback (λ (i) + (define fn (send definitions-text get-filename)) + (send i set-label + (if fn + (format (string-constant module-browser-in-file) fn) + (string-constant module-browser-no-file))) + (send i enable fn))] + [callback (λ (x y) + (define fn (send definitions-text get-filename)) + (when fn + (drracket:module-overview:module-overview/file fn this)))]) (make-object separator-menu-item% language-specific-menu) (let ([cap-val diff --git a/collects/mrlib/graph.rkt b/collects/mrlib/graph.rkt index f7edc43bc1..b9b5b89916 100644 --- a/collects/mrlib/graph.rkt +++ b/collects/mrlib/graph.rkt @@ -11,6 +11,8 @@ graph-pasteboard<%> graph-pasteboard-mixin) + (define-local-member-name invalidate-edge-cache) + (define graph-snip<%> (interface () get-children @@ -163,7 +165,9 @@ (define graph-snip-mixin (mixin ((class->interface snip%)) (graph-snip<%>) - (field (children null)) + (inherit get-admin) + + (define children null) (define/public (get-children) children) (define/public (add-child child) (unless (memq child children) @@ -172,7 +176,7 @@ (when (memq child children) (set! children (remq child children)))) - (field (parent-links null)) + (define parent-links null) (define/public (get-parent-links) parent-links) (define/public (get-parents) (map link-snip parent-links)) (define/public add-parent @@ -184,6 +188,11 @@ (add-parent parent dark-pen light-pen dark-brush light-brush #f #f dx dy #f)] [(parent dark-pen light-pen dark-brush light-brush dark-text light-text dx dy label) (unless (memf (lambda (parent-link) (eq? (link-snip parent-link) parent)) parent-links) + (define admin (get-admin)) + (when admin + (define ed (send admin get-editor)) + (when (is-a? ed graph-pasteboard<%>) + (send ed invalidate-edge-cache))) (set! parent-links (cons (make-link parent (or dark-pen default-dark-pen) @@ -260,7 +269,8 @@ (inherit find-first-snip find-next-selected-snip) (init-field [edge-label-font #f] - [edge-labels? #t]) + [edge-labels? #t] + [cache-arrow-drawing? #f]) (define draw-arrow-heads? #t) (define flip-labels? #t) @@ -524,6 +534,40 @@ (super on-paint before? dc left top right bottom dx dy draw-caret)) (define/public (draw-edges dc left top right bottom dx dy) + (cond + [cache-arrow-drawing? + (define admin (get-admin)) + (when admin + (define-values (x y w h) + (let ([xb (box 0)] + [yb (box 0)] + [wb (box 0)] + [hb (box 0)]) + (send admin get-max-view xb yb wb hb) + (values (unbox xb) (unbox yb) (unbox wb) (unbox hb)))) + (define this-time (list x y w h)) + (unless (and edges-cache (equal? this-time edges-cache-last-time)) + (set! edges-cache-last-time this-time) + (set! edges-cache (make-bitmap (inexact->exact (ceiling w)) + (inexact->exact (ceiling h)))) + (define bdc (make-object bitmap-dc% edges-cache)) + (draw-edges/compute bdc x y (+ x w) (+ y h) dx dy #f) + (send bdc set-bitmap #f)) + (send dc draw-bitmap edges-cache 0 0) + (draw-edges/compute dc left top right bottom dx dy #t))] + [else + (draw-edges/compute dc left top right bottom dx dy #f) + (draw-edges/compute dc left top right bottom dx dy #t)])) + + (define/augment (on-change) + (set! edges-cache #f) + (inner (void) on-change)) + + (define/public (invalidate-edge-cache) (set! edges-cache #f)) + (define edges-cache #f) + (define edges-cache-last-time #f) + + (define/private (draw-edges/compute dc left top right bottom dx dy draw-dark-lines?) ;; draw-connection : link snip boolean boolean -> void ;; sets the drawing context (pen and brush) ;; determines if the connection is between a snip and itself or two different snips @@ -681,12 +725,12 @@ left top right bottom (lambda (from-link to) (let ([from (link-snip from-link)]) - (cond - [(or (memq from currently-overs) - (memq to currently-overs)) - (set! pairs (cons (cons from-link to) pairs))] - [else - (draw-connection from-link to #f)])))) + (when (and (or (memq from currently-overs) + (memq to currently-overs)) + draw-dark-lines?) + (set! pairs (cons (cons from-link to) pairs))) + (unless draw-dark-lines? + (draw-connection from-link to #f))))) (for-each (lambda (pr) (draw-connection (car pr) (cdr pr) #t)) pairs)) diff --git a/collects/mrlib/scribblings/graph/graph-pasteboard-mixin.scrbl b/collects/mrlib/scribblings/graph/graph-pasteboard-mixin.scrbl index 0dd2a8ac35..0569139904 100644 --- a/collects/mrlib/scribblings/graph/graph-pasteboard-mixin.scrbl +++ b/collects/mrlib/scribblings/graph/graph-pasteboard-mixin.scrbl @@ -4,7 +4,8 @@ @defmixin/title[graph-pasteboard-mixin (pasteboard%) (graph-pasteboard<%>)]{ @defconstructor/auto-super[([edge-labels? boolean? #t] - [edge-label-font (or/c #f (is-a?/c font%)) #f])]{ + [edge-label-font (or/c #f (is-a?/c font%)) #f] + [cache-arrow-drawing? any])]{ If @scheme[edge-labels?] is @scheme[#f], no edge labels are drawn. Otherwise, they are. @@ -13,6 +14,10 @@ If @scheme[edge-label-font] is supplied, it is used when drawing the labels on the edges. Otherwise, the font is not set before drawing the labels, defaulting to the @scheme[dc<%>] object's font. +If @racket[cache-arrow-drawing?] is @racket[#f], then the arrows in the snip +are not cached in a bitmap (to speed up drawing when the mouse moves around). +Otherwise, they are. + } This mixin overrides many methods to draw lines between diff --git a/collects/scribblings/drracket/interface-essentials.scrbl b/collects/scribblings/drracket/interface-essentials.scrbl index 04ece79c06..9dc668e139 100644 --- a/collects/scribblings/drracket/interface-essentials.scrbl +++ b/collects/scribblings/drracket/interface-essentials.scrbl @@ -711,8 +711,9 @@ file cannot be included in another debugging session. @section[#:tag "module-browser"]{The Module Browser} The module browser shows you the structure of all of the files in your program. -It can be opened via the @onscreen{Show} menu, or via the @onscreen{Module Browser ...} -menu item in the @onscreen{Racket} menu. +It can be opened via the @onscreen{Show} menu, or via the +@onscreen{Module Browser} +menu items in the @onscreen{Racket} menu. A module browser window contains a square for each module. The squares are colored based on the number of @@ -726,13 +727,18 @@ A module browser window contains a square for each right, but since modules can be moved around interactively, that property might not be preserved. - To open the file corresponding to the module, right-click or - control-click (Mac OS X) on the box for that module. + To open the file corresponding to the module, double click + on the box for that module. The module browser will also show you the phases that each module is loaded in; choose the ``Long, with phases'' menu item in the ``Names'' pop-up menu. The integers indicate the phases and if @racket[#f] is present, it means the module is loaded @racket[for-label]. + + The bar along the bottom helps you find your way in a module graph. Specifically, + if you type something there, then all of the modules whose filenames match + what you type will turn green in the module window. This bar is only visible + in the stand alone module browser window (via the @onscreen{Racket} menu) @section[#:tag "create-exe"]{Creating Executables} diff --git a/collects/scribblings/drracket/menus.scrbl b/collects/scribblings/drracket/menus.scrbl index bc13ca80e8..096b028dc2 100644 --- a/collects/scribblings/drracket/menus.scrbl +++ b/collects/scribblings/drracket/menus.scrbl @@ -303,12 +303,21 @@ portions of the program.} info.} @item{@defmenuitem{Module Browser...} Prompts for a file and - then opens a window showing the module import structure - for the module import DAG starting at the selected module. + then opens a window showing the module + DAG starting at the module in the selected file. See also @secref["module-browser"]. } +@item{@defmenuitem{Module Browser on @italic{file}} + Opens a separate window showing the module graph rooted at the + file currently being edited in DrRacket, but + using the saved file on the disk, instead of the + version in DrRacket. + + See also @secref["module-browser"]. + } + @item{@defmenuitem{Reindent} Indents the selected text according to the standard Racket formatting conventions. (Pressing the Tab key has the same effect.)} diff --git a/collects/string-constants/english-string-constants.rkt b/collects/string-constants/english-string-constants.rkt index 3508a9e06a..364b448cdf 100644 --- a/collects/string-constants/english-string-constants.rkt +++ b/collects/string-constants/english-string-constants.rkt @@ -1229,6 +1229,8 @@ please adhere to these guidelines: (module-browser-open-file-format "Open ~a") (module-browser "Module Browser") ;; frame title (module-browser... "&Module Browser...") ;; menu item title + (module-browser-in-file "M&odule Browser on ~a") ;; menu item title; ~a is filled with a filename + (module-browser-no-file "Module Browser on This Saved File") ;; menu item title for above menu item; used when there is no saved file (module-browser-error-expanding "Error expanding the program:\n\n~a") (module-browser-show-lib-paths "Show files loaded by (lib ..) paths") (module-browser-progress "Module Browser: ~a") ;; prefix in the status line @@ -1236,7 +1238,8 @@ please adhere to these guidelines: (module-browser-show-lib-paths/short "Follow lib requires") ;; check box label in show module browser pane in drscheme window. (module-browser-show-planet-paths/short "Follow PLaneT requires") ;; check box label in show module browser pane in drscheme window. (module-browser-refresh "Refresh") ;; button label in show module browser pane in drscheme window. - (module-browser-only-in-plt-and-module-langs + (module-browser-highlight "Highlight") ;; used to search in the graph; the label on a text-field% object + (module-browser-only-in-plt-and-module-langs "The module browser is only available for module-based programs.") (module-browser-name-length "Name length") (module-browser-name-short "Short")