Two improvements to the mrlib/graph library and the module browser:
- improved the drawing speed in mrlib's graph pasteboard by caching the background arrows (optionally; only turned on for the module browser. in redex, this probably won't speed anything up so it isn't used) - added a search feature to the module graph to help find dependencies; type in string and some of the graph changes color
This commit is contained in:
Robby Findler
parent
09a0109605
commit
e928bd840c
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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,14 +727,19 @@ 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}
|
||||
|
||||
DrRacket's @onscreen{Create Executable...} menu item lets you create
|
||||
|
|
|
|||
|
|
@ -303,8 +303,17 @@ 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"].
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user