[racket-dev] [plt] Push #28525: master branch updated

From: Robby Findler (robby at eecs.northwestern.edu)
Date: Mon Apr 14 16:46:04 EDT 2014

Yes, please! Thank you.

Robby

On Mon, Apr 14, 2014 at 3:43 PM, Vincent St-Amour <stamourv at ccs.neu.edu> wrote:
> This does not handle relative paths.
>
> I attached a patch that solves the issue, but I'm not sure that's the
> right way to do it. It seems like a better solution may be to fix
> `get-init-dir' in eval-helpers.rkt, but that may have broader
> consequences.
>
> If the patch looks reasonable, I'll push it.
>
> Vincent
>
>
>
>
>
>
>
>
> At Sat, 12 Apr 2014 14:28:47 -0400,
> robby at racket-lang.org wrote:
>>
>> robby has updated `master' from 1f5d08dc29 to e8529ac30a.
>>   http://git.racket-lang.org/plt/1f5d08dc29..e8529ac30a
>>
>> =====[ One Commit ]=====================================================
>> Directory summary:
>>   99.5% pkgs/drracket-pkgs/drracket/drracket/private/
>>
>> ~~~~~~~~~~
>>
>> e8529ac Robby Findler <robby at racket-lang.org> 2014-04-12 13:26
>> :
>> | add 'raco dependencies-graph'
>> |
>> | That is, refactor DrRacket's module browser so that
>> | it can be run outside of DrRacket.
>> :
>>   M .../drracket/drracket/private/main.rkt            |   12 -
>>   M .../drracket/drracket/private/module-browser.rkt  | 1743 ++++++++++--------
>>   M .../drracket/drracket/private/unit.rkt            |    1 -
>>   M pkgs/drracket-pkgs/drracket/drracket/info.rkt     |    5 +
>>   A pkgs/drracket-pkgs/drracket/drracket/private/standalone-module-browser.rkt
>>   M .../private/english-string-constants.rkt          |    2 +-
>>
>> =====[ Overall Diff ]===================================================
>>
>> pkgs/drracket-pkgs/drracket/drracket/info.rkt
>> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
>> --- OLD/pkgs/drracket-pkgs/drracket/drracket/info.rkt
>> +++ NEW/pkgs/drracket-pkgs/drracket/drracket/info.rkt
>> @@ -89,3 +89,8 @@
>>      'white-on-black-base? #t
>>      'colors tol-white-on-black-colors)))
>>
>> +(define raco-commands
>> +  (list (list "dependencies-graph"
>> +              'drracket/private/standalone-module-browser
>> +              "opens a GUI window showing transitive module dependencies (aka `Module Browser')"
>> +              #f)))
>>
>> pkgs/drracket-pkgs/drracket/drracket/private/main.rkt
>> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
>> --- OLD/pkgs/drracket-pkgs/drracket/drracket/private/main.rkt
>> +++ NEW/pkgs/drracket-pkgs/drracket/drracket/private/main.rkt
>> @@ -179,9 +179,6 @@
>>                             3/4
>>                             number-between-zero-and-one?))
>>
>> -(drr:set-default 'drracket:module-browser:name-length 1
>> -                         (λ (x) (memq x '(0 1 2 3))))
>> -
>>  (let ([frame-width 600]
>>        [frame-height 650]
>>        [window-trimming-upper-bound-width 20]
>> @@ -271,15 +268,6 @@
>>   null
>>   list?)
>>
>> -  (drr:set-default 'drracket:module-overview:label-font-size 12 number?)
>> -  (drr:set-default 'drracket:module-overview:window-height 500 number?)
>> -  (drr:set-default 'drracket:module-overview:window-width 500 number?)
>> -  (drr:set-default 'drracket:module-browser:hide-paths '(lib)
>> -                           (λ (x)
>> -                             (and (list? x)
>> -                                  (andmap symbol? x))))
>> -
>> -
>>  (drracket:font:setup-preferences)
>>  (color-prefs:add-color-scheme-preferences-panel
>>   #:extras
>>
>> pkgs/drracket-pkgs/drracket/drracket/private/module-browser.rkt
>> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
>> --- OLD/pkgs/drracket-pkgs/drracket/drracket/private/module-browser.rkt
>> +++ NEW/pkgs/drracket-pkgs/drracket/drracket/private/module-browser.rkt
>> @@ -1,11 +1,6 @@
>>  #lang racket/base
>>
>> -(define oprintf
>> -  (let ([op (current-output-port)])
>> -    (λ args
>> -      (apply fprintf op args))))
>> -
>> -(require mred
>> +(require racket/gui/base
>>           racket/class
>>           racket/set
>>           racket/contract
>> @@ -24,6 +19,25 @@
>>           racket/port
>>           "rectangle-intersect.rkt")
>>
>> +(define oprintf
>> +  (let ([op (current-output-port)])
>> +    (λ args
>> +      (apply fprintf op args))))
>> +
>> +(provide standalone-module-overview/file)
>> +
>> +
>> +
>> +(preferences:set-default 'drracket:module-overview:label-font-size 12 number?)
>> +(preferences:set-default 'drracket:module-overview:window-height 500 number?)
>> +(preferences:set-default 'drracket:module-overview:window-width 500 number?)
>> +(preferences:set-default 'drracket:module-browser:hide-paths '(lib)
>> +                         (λ (x)
>> +                           (and (list? x)
>> +                                (andmap symbol? x))))
>> +(preferences:set-default 'drracket:module-browser:name-length 1
>> +                         (λ (x) (memq x '(0 1 2 3))))
>> +
>>  (define-struct req (r-mpi key))
>>  ;; type req = (make-req [result from resolve-module-path-index] -- except only when it has a path
>>  ;;                      (or/c symbol? #f))
>> @@ -43,647 +57,55 @@
>>  (define original-output-port (current-output-port))
>>  (define original-error-port (current-error-port))
>>
>> +(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 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 (set-box/f b v) (when (box? b) (set-box! b v)))
>> +
>> +(define (find-label-font size)
>> +  (send the-font-list find-or-create-font size 'decorative 'normal 'normal #f))
>> +
>> +(define module-overview-pasteboard<%>
>> +  (interface ()
>> +    set-label-font-size
>> +    get-label-font-size
>> +    get-hidden-paths
>> +    show-visible-paths
>> +    remove-visible-paths
>> +    set-name-length
>> +    get-name-length))
>> +
>> +(define boxed-word-snip<%>
>> +  (interface ()
>> +    get-filename
>> +    get-word
>> +    get-lines
>> +    is-special-key-child?
>> +    add-special-key-child
>> +    set-found!))
>> +
>>  (define-unit module-overview@
>>    (import [prefix drracket:frame: drracket:frame^]
>>            [prefix drracket:eval: drracket:eval^]
>>            [prefix drracket:language-configuration: drracket:language-configuration/internal^]
>>            [prefix drracket:language: drracket:language^])
>> -  (export drracket:module-overview^)
>> -
>> -  (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 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 (set-box/f b v) (when (box? b) (set-box! b v)))
>> +  (export (rename drracket:module-overview^
>> +                  [_module-overview/file module-overview/file]
>> +                  [_make-module-overview-pasteboard make-module-overview-pasteboard]))
>>
>>    (define (module-overview parent)
>>      (let ([filename (get-file #f parent)])
>>        (when filename
>> -        (module-overview/file filename parent))))
>> -
>> -  (define (find-label-font size)
>> -    (send the-font-list find-or-create-font size 'decorative 'normal 'normal #f))
>> -
>> -  (define module-overview-pasteboard<%>
>> -    (interface ()
>> -      set-label-font-size
>> -      get-label-font-size
>> -      get-hidden-paths
>> -      show-visible-paths
>> -      remove-visible-paths
>> -      set-name-length
>> -      get-name-length))
>> -
>> -  (define boxed-word-snip<%>
>> -    (interface ()
>> -      get-filename
>> -      get-word
>> -      get-lines
>> -      is-special-key-child?
>> -      add-special-key-child
>> -      set-found!))
>> -
>> -  ;; make-module-overview-pasteboard : boolean
>> -  ;;                                   ((union #f snip) -> void)
>> -  ;;                                -> (union string pasteboard)
>> -  ;; string as result indicates an error message
>> -  ;; pasteboard as result is the pasteboard to show
>> -  (define (make-module-overview-pasteboard vertical? mouse-currently-over)
>> -
>> -    (define level-ht (make-hasheq))
>> -
>> -    ;; 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 "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))
>> -    (define light-syntax-pen (send the-pen-list find-or-create-pen "plum" 1 'solid))
>> -    (define light-syntax-brush (send the-brush-list find-or-create-brush "plum" 'solid))
>> -
>> -    (define dark-template-pen (send the-pen-list find-or-create-pen "seagreen" 1 'solid))
>> -    (define dark-template-brush (send the-brush-list find-or-create-brush "seagreen" 'solid))
>> -    (define light-template-pen (send the-pen-list find-or-create-pen "springgreen" 1 'solid))
>> -    (define light-template-brush (send the-brush-list find-or-create-brush "springgreen" 'solid))
>> -
>> -    (define dark-pen (send the-pen-list find-or-create-pen "blue" 1 'solid))
>> -    (define dark-brush (send the-brush-list find-or-create-brush "blue" 'solid))
>> -    (define light-pen (send the-pen-list find-or-create-pen "light blue" 1 'solid))
>> -    (define light-brush (send the-brush-list find-or-create-brush "light blue" 'solid))
>> -
>> -    (define (module-overview-pasteboard-mixin %)
>> -      (class* % (module-overview-pasteboard<%>)
>> -
>> -        (inherit get-snip-location
>> -                 begin-edit-sequence
>> -                 end-edit-sequence
>> -                 insert
>> -                 move-to
>> -                 find-first-snip
>> -                 dc-location-to-editor-location
>> -                 find-snip
>> -                 get-canvas)
>> -
>> -        ;; require-depth-ht : hash[(list snip snip) -o> (listof integer)]
>> -        ;; maps parent/child snips (ie, those that match up to modules
>> -        ;; that require each other) to phase differences
>> -        (define require-depth-ht (make-hash))
>> -
>> -        (define name-length 'long)
>> -        (define/public (set-name-length nl)
>> -          (unless (eq? name-length nl)
>> -            (set! name-length nl)
>> -            (re-add-snips)
>> -            (render-snips)))
>> -        (define/public (get-name-length) name-length)
>> -
>> -        (field [max-lines #f])
>> -
>> -        ;; controls if the snips should be moved
>> -        ;; around when the font size is changed.
>> -        ;; set to #f if the user ever moves a
>> -        ;; snip themselves.
>> -        (define dont-move-snips #f)
>> -
>> -        (field (label-font-size (preferences:get 'drracket:module-overview:label-font-size)))
>> -        (define/public (get-label-font-size) label-font-size)
>> -        (define/private (get-snip-hspace) (if vertical?
>> -                                              2
>> -                                              (* 2 label-font-size)))
>> -        (define/private (get-snip-vspace) (if vertical?
>> -                                              30
>> -                                              2))
>> -        (define snip-height #f)
>> -
>> -        (define font-label-size-callback-running? #f)
>> -        (define new-font-size #f)
>> -        (define/public (set-label-font-size size-to-set)
>> -          (set! new-font-size size-to-set)
>> -          (unless font-label-size-callback-running?
>> -            (set! font-label-size-callback-running? #t)
>> -            (queue-callback
>> -             (λ ()
>> -               (set! label-font-size new-font-size)
>> -               (preferences:set 'drracket:module-overview:label-font-size
>> -                                new-font-size)
>> -               (set! label-font (find-label-font label-font-size))
>> -               (begin-edit-sequence)
>> -               (let loop ([snip (find-first-snip)])
>> -                 (when snip
>> -                   (let ([admin (send snip get-admin)])
>> -                     (when admin
>> -                       (send admin resized snip #t)))
>> -                   (loop (send snip next))))
>> -               (unless dont-move-snips
>> -                 (render-snips))
>> -               (end-edit-sequence)
>> -               (set! new-font-size #f)
>> -               (set! font-label-size-callback-running? #f))
>> -             #f)))
>> -
>> -        (define/public (begin-adding-connections)
>> -          (when max-lines
>> -            (error 'begin-adding-connections
>> -                   "already in begin-adding-connections/end-adding-connections sequence"))
>> -          (set! max-lines 0)
>> -          (begin-edit-sequence)
>> -          (let loop ()
>> -            (let ([s (find-first-snip)])
>> -              (when s
>> -                (send s release-from-owner)
>> -                (loop))))
>> -          (set! level-ht (make-hasheq))
>> -          (set! snip-table (make-hash)))
>> -
>> -        (define/public (end-adding-connections)
>> -          (unless max-lines
>> -            (error 'end-adding-connections
>> -                   "not in begin-adding-connections/end-adding-connections sequence"))
>> -
>> -          (unless (zero? max-lines)
>> -            (let loop ([snip (find-first-snip)])
>> -              (when snip
>> -                (when (is-a? snip word-snip/lines%)
>> -                  (send snip normalize-lines max-lines))
>> -                (loop (send snip next)))))
>> -
>> -
>> -          (set! max-lines #f)
>> -          (compute-snip-require-phases)
>> -          (remove-specially-linked)
>> -          (render-snips)
>> -          (end-edit-sequence))
>> -
>> -        (define/private (compute-snip-require-phases)
>> -          (let ([ht (make-hash)]) ;; avoid infinite loops
>> -            (for ([snip (in-list (get-top-most-snips))])
>> -              (let loop ([parent snip]
>> -                         [depth 0])    ;; depth is either an integer or #f (indicating for-label)
>> -                (unless (hash-ref ht (cons parent depth) #f)
>> -                  (hash-set! ht (cons parent depth) #t)
>> -                  (send parent add-require-phase depth)
>> -                  (for ([child (in-list (send parent get-children))])
>> -                    (for ([delta-depth (in-list (hash-ref require-depth-ht (list parent child)))])
>> -                      (loop child
>> -                            (and depth delta-depth (+ delta-depth depth))))))))))
>> -
>> -        ;; add-connection : path/string/submod path/string/submod (union symbol #f) number -> 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/public (add-connection name-original name-require path-key require-depth)
>> -          (unless max-lines
>> -            (error 'add-connection "not in begin-adding-connections/end-adding-connections sequence"))
>> -          (let* ([original-snip (find/create-snip name-original)]
>> -                 [require-snip (find/create-snip name-require)]
>> -                 [original-level (send original-snip get-level)]
>> -                 [require-level (send require-snip get-level)])
>> -            (let ([require-depth-key (list original-snip require-snip)])
>> -              (hash-set! require-depth-ht
>> -                         require-depth-key
>> -                         (cons require-depth (hash-ref require-depth-ht require-depth-key '()))))
>> -            (case require-depth
>> -              [(0)
>> -               (add-links original-snip require-snip
>> -                          dark-pen light-pen
>> -                          dark-brush light-brush)]
>> -              [else
>> -               (add-links original-snip require-snip
>> -                          dark-syntax-pen light-syntax-pen
>> -                          dark-syntax-brush light-syntax-brush)])
>> -            (when path-key
>> -              (send original-snip add-special-key-child path-key require-snip))
>> -            (if (send original-snip get-level)
>> -                (fix-snip-level require-snip (+ original-level 1))
>> -                (fix-snip-level original-snip 0))))
>> -
>> -        ;; fix-snip-level : snip number -> void
>> -        ;; moves the snip (and any children) to at least `new-level'
>> -        ;; doesn't move them if they are already past that level
>> -        (define/private (fix-snip-level snip new-min-level)
>> -          (let loop ([snip snip]
>> -                     [new-min-level new-min-level])
>> -            (let ([current-level (send snip get-level)])
>> -              (when (or (not current-level)
>> -                        (new-min-level . > . current-level))
>> -                (send snip set-level new-min-level)
>> -                (for-each
>> -                 (λ (child) (loop child (+ new-min-level 1)))
>> -                 (send snip get-children))))))
>> -
>> -        ;; find/create-snip : (union path string) boolean? -> word-snip/lines
>> -        ;; finds the snip with this key, or creates a new
>> -        ;; ones. For the same key, always returns the same snip.
>> -        ;; uses snip-table as a cache for this purpose.
>> -        (define/private (find/create-snip name)
>> -          (define filename
>> -            (match name
>> -              [(? path-string?) (and (file-exists? name) name)]
>> -              [`(submod ,p ,_ ...) (and (file-exists? p) p)]
>> -              [else #f]))
>> -          (hash-ref
>> -           snip-table
>> -           name
>> -           (λ ()
>> -             (define snip
>> -               (new word-snip/lines%
>> -                    [lines (if filename (count-lines filename) #f)]
>> -                    [word
>> -                     (if filename
>> -                         (let ([short-name (let-values ([(_1 name _2) (split-path filename)])
>> -                                             (path->string name))])
>> -                           (match name
>> -                             [(? path-string?) short-name]
>> -                             [`(submod ,p ,submods ...)
>> -                              (format "~s" `(submod ,short-name , at submods))]))
>> -                         (format "~a" name))]
>> -                    [pb this]
>> -                    [filename filename]))
>> -             (insert snip)
>> -             (hash-set! snip-table name snip)
>> -             snip)))
>> -
>> -        ;; count-lines : string[filename] -> (union #f number)
>> -        ;; effect: updates max-lines
>> -        (define/private (count-lines filename)
>> -          (let ([lines
>> -                 (call-with-input-file filename
>> -                   (λ (port)
>> -                     (let loop ([n 0])
>> -                       (let ([l (read-line port)])
>> -                         (if (eof-object? l)
>> -                             n
>> -                             (loop (+ n 1))))))
>> -                   #:mode 'text)])
>> -            (set! max-lines (max lines max-lines))
>> -            lines))
>> -
>> -        ;; get-snip-width : snip -> number
>> -        ;; exracts the width of a snip
>> -        (define/private (get-snip-width snip)
>> -          (let ([lb (box 0)]
>> -                [rb (box 0)])
>> -            (get-snip-location snip lb #f #f)
>> -            (get-snip-location snip rb #f #t)
>> -            (- (unbox rb)
>> -               (unbox lb))))
>> -
>> -        ;; get-snip-height : snip -> number
>> -        ;; exracts the width of a snip
>> -        (define/private (get-snip-height snip)
>> -          (let ([tb (box 0)]
>> -                [bb (box 0)])
>> -            (get-snip-location snip #f tb #f)
>> -            (get-snip-location snip #f bb #t)
>> -            (- (unbox bb)
>> -               (unbox tb))))
>> -
>> -        (field [hidden-paths (preferences:get 'drracket:module-browser:hide-paths)])
>> -        (define/public (remove-visible-paths symbol)
>> -          (unless (memq symbol hidden-paths)
>> -            (set! hidden-paths (cons symbol hidden-paths))
>> -            (refresh-visible-paths)))
>> -        (define/public (show-visible-paths symbol)
>> -          (when (memq symbol hidden-paths)
>> -            (set! hidden-paths (remq symbol hidden-paths))
>> -            (refresh-visible-paths)))
>> -        (define/public (get-hidden-paths) hidden-paths)
>> -
>> -        (define/private (refresh-visible-paths)
>> -          (begin-edit-sequence)
>> -          (re-add-snips)
>> -          (render-snips)
>> -          (end-edit-sequence))
>> -
>> -        (define/private (re-add-snips)
>> -          (begin-edit-sequence)
>> -          (remove-specially-linked)
>> -          (end-edit-sequence))
>> -
>> -        (define/private (remove-specially-linked)
>> -          (remove-currrently-inserted)
>> -          (cond
>> -            [(null? hidden-paths)
>> -             (add-all)]
>> -            [else
>> -             (let ([ht (make-hasheq)])
>> -               (for ([snip (in-list (get-top-most-snips))])
>> -                 (insert snip)
>> -                 (let loop ([snip snip])
>> -                   (unless (hash-ref ht snip #f)
>> -                     (hash-set! ht snip #t)
>> -                     (for ([child (in-list (send snip get-children))])
>> -                       (unless (ormap (λ (key) (send snip is-special-key-child?
>> -                                                     key child))
>> -                                      hidden-paths)
>> -                         (insert child)
>> -                         (loop child)))))))]))
>> -
>> -        (define/private (remove-currrently-inserted)
>> -          (let loop ()
>> -            (let ([snip (find-first-snip)])
>> -              (when snip
>> -                (send snip release-from-owner)
>> -                (loop)))))
>> -
>> -        (define/private (add-all)
>> -          (let ([ht (make-hasheq)])
>> -            (for-each
>> -             (λ (snip)
>> -               (let loop ([snip snip])
>> -                 (unless (hash-ref ht snip (λ () #f))
>> -                   (hash-set! ht snip #t)
>> -                   (insert snip)
>> -                   (for-each loop (send snip get-children)))))
>> -             (get-top-most-snips))))
>> -
>> -        (define/private (get-top-most-snips) (hash-ref level-ht 0 (λ () null)))
>> -
>> -        ;; render-snips : -> void
>> -        (define/public (render-snips)
>> -          (begin-edit-sequence)
>> -          (let ([max-minor 0])
>> -
>> -            ;; major-dim is the dimension that new levels extend along
>> -            ;; minor-dim is the dimension that snips inside a level extend along
>> -
>> -            (hash-for-each
>> -             level-ht
>> -             (λ (n v)
>> -               (set! max-minor (max max-minor (apply + (map (if vertical?
>> -                                                                (λ (x) (get-snip-width x))
>> -                                                                (λ (x) (get-snip-height x)))
>> -                                                            v))))))
>> -
>> -            (let ([levels (sort (hash-map level-ht list)
>> -                                (λ (x y) (<= (car x) (car y))))])
>> -              (let loop ([levels levels]
>> -                         [major-dim 0])
>> -                (cond
>> -                  [(null? levels) (void)]
>> -                  [else
>> -                   (let* ([level (car levels)]
>> -                          [n (car level)]
>> -                          [this-level-snips (cadr level)]
>> -                          [this-minor (apply + (map (if vertical?
>> -                                                        (λ (x) (get-snip-width x))
>> -                                                        (λ (x) (get-snip-height x)))
>> -                                                    this-level-snips))]
>> -                          [this-major (apply max (map (if vertical?
>> -                                                          (λ (x) (get-snip-height x))
>> -                                                          (λ (x) (get-snip-width x)))
>> -                                                      this-level-snips))])
>> -                     (let loop ([snips this-level-snips]
>> -                                [minor-dim (/ (- max-minor this-minor) 2)])
>> -                       (unless (null? snips)
>> -                         (let* ([snip (car snips)]
>> -                                [new-major-coord
>> -                                 (+ major-dim
>> -                                    (floor
>> -                                     (- (/ this-major 2)
>> -                                        (/ (if vertical?
>> -                                               (get-snip-height snip)
>> -                                               (get-snip-width snip))
>> -                                           2))))])
>> -                           (if vertical?
>> -                               (move-to snip minor-dim new-major-coord)
>> -                               (move-to snip new-major-coord minor-dim))
>> -                           (loop (cdr snips)
>> -                                 (+ minor-dim
>> -                                    (if vertical?
>> -                                        (get-snip-hspace)
>> -                                        (get-snip-vspace))
>> -                                    (if vertical?
>> -                                        (get-snip-width snip)
>> -                                        (get-snip-height snip)))))))
>> -                     (loop (cdr levels)
>> -                           (+ major-dim
>> -                              (if vertical?
>> -                                  (get-snip-vspace)
>> -                                  (get-snip-hspace))
>> -                              this-major)))]))))
>> -          (end-edit-sequence))
>> -
>> -        (define/override (on-mouse-over-snips snips)
>> -          (mouse-currently-over snips))
>> -
>> -        (define/override (on-double-click snip event)
>> -          (cond
>> -            [(is-a? snip boxed-word-snip<%>)
>> -             (let ([fn (send snip get-filename)])
>> -               (when fn
>> -                 (handler:edit-file fn)))]
>> -            [else (super on-double-click snip event)]))
>> -
>> -        (define/override (on-event evt)
>> -          (cond
>> -            [(send evt button-down? 'right)
>> -             (let ([ex (send evt get-x)]
>> -                   [ey (send evt get-y)])
>> -               (let-values ([(x y) (dc-location-to-editor-location ex ey)])
>> -                 (let ([snip (find-snip x y)]
>> -                       [canvas (get-canvas)])
>> -                   (let ([right-button-menu (make-object popup-menu%)])
>> -                     (when (and snip
>> -                                (is-a? snip boxed-word-snip<%>)
>> -                                canvas
>> -                                (send snip get-filename))
>> -                       (instantiate menu-item% ()
>> -                         (label
>> -                          (trim-string
>> -                           (format open-file-format
>> -                                   (path->string (send snip get-filename)))
>> -                           200))
>> -                         (parent right-button-menu)
>> -                         (callback
>> -                          (λ (x y)
>> -                            (handler:edit-file
>> -                             (send snip get-filename))))))
>> -                     (instantiate menu-item% ()
>> -                       (label (string-constant module-browser-open-all))
>> -                       (parent right-button-menu)
>> -                       (callback
>> -                        (λ (x y)
>> -                          (let loop ([snip (find-first-snip)])
>> -                            (when snip
>> -                              (when (is-a? snip boxed-word-snip<%>)
>> -                                (let ([filename (send snip get-filename)])
>> -                                  (handler:edit-file filename)))
>> -                              (loop (send snip next)))))))
>> -                     (send canvas popup-menu
>> -                           right-button-menu
>> -                           (+ (send evt get-x) 1)
>> -                           (+ (send evt get-y) 1))))))]
>> -            [else (super on-event evt)]))
>> -
>> -        (super-new)))
>> -
>> -    (define (trim-string str len)
>> -      (cond
>> -        [(<= (string-length str) len) str]
>> -        [else (substring str (- (string-length str) len) (string-length str))]))
>> -
>> -    (define (level-mixin %)
>> -      (class %
>> -        (field (level #f))
>> -        (define/public (get-level) level)
>> -        (define/public (set-level _l)
>> -          (when level
>> -            (hash-set! level-ht level
>> -                       (remq this (hash-ref level-ht level))))
>> -          (set! level _l)
>> -          (hash-set! level-ht level
>> -                     (cons this (hash-ref level-ht level (λ () null)))))
>> -
>> -        (super-instantiate ())))
>> -
>> -    (define (boxed-word-snip-mixin %)
>> -      (class* % (boxed-word-snip<%>)
>> -        (init-field word
>> -                    filename
>> -                    lines
>> -                    pb)
>> -
>> -        (inherit get-admin)
>> -
>> -        (define require-phases '())
>> -        (define/public (get-require-phases) require-phases)
>> -        (define/public (add-require-phase d)
>> -          (unless (member d require-phases)
>> -            (set! last-name #f)
>> -            (set! last-size #f)
>> -            (set! require-phases (sort (cons d require-phases) < #:key (λ (x) (or x +inf.0))))))
>> -
>> -        (field [special-children (make-hasheq)])
>> -        (define/public (is-special-key-child? key child)
>> -          (let ([ht (hash-ref special-children key #f)])
>> -            (and ht (hash-ref ht child #f))))
>> -        (define/public (add-special-key-child key child)
>> -          (hash-set! (hash-ref! special-children key make-hasheq) child #t))
>> -
>> -        (define/public (get-filename) filename)
>> -        (define/public (get-word) word)
>> -        (define/public (get-lines) lines)
>> -
>> -        (field (lines-brush #f))
>> -        (define/public (normalize-lines n)
>> -          (if lines
>> -              (let* ([grey (inexact->exact (floor (- 255 (* 255 (sqrt (/ lines n))))))])
>> -                (set! lines-brush (send the-brush-list find-or-create-brush
>> -                                        (make-object color% grey grey grey)
>> -                                        'solid)))
>> -              (set! lines-brush (send the-brush-list find-or-create-brush
>> -                                      "salmon"
>> -                                      'solid))))
>> -
>> -        (define snip-width 0)
>> -        (define snip-height 0)
>> -
>> -        (define/override (get-extent dc x y wb hb descent space lspace rspace)
>> -          (cond
>> -            [(equal? (name->label) "")
>> -             (set! snip-width 15)
>> -             (set! snip-height 15)]
>> -            [else
>> -             (let-values ([(w h a d) (send dc get-text-extent (name->label) label-font)])
>> -               (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)
>> -          (set-box/f space 0)
>> -          (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-pen (send dc get-pen)])
>> -            (send dc set-font label-font)
>> -            (cond
>> -              [found-highlight?
>> -               (send dc set-brush search-result-background 'solid)]
>> -              [lines-brush
>> -               (send dc set-brush lines-brush)])
>> -            (when (rectangles-intersect? left top right bottom
>> -                                         x y (+ x snip-width) (+ y snip-height))
>> -              (send dc draw-rectangle x y snip-width snip-height)
>> -              (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)))
>> -
>> -        ;; name->label : path -> string
>> -        ;; constructs a label for the little boxes in terms
>> -        ;; of the filename.
>> -
>> -        (define last-name #f)
>> -        (define last-size #f)
>> -
>> -        (define/private (name->label)
>> -          (let ([this-size (send pb get-name-length)])
>> -            (cond
>> -              [(eq? this-size last-size) last-name]
>> -              [else
>> -               (set! last-size this-size)
>> -               (set! last-name
>> -                     (case last-size
>> -                       [(short)
>> -                        (if (string=? word "")
>> -                            ""
>> -                            (string (string-ref word 0)))]
>> -                       [(medium)
>> -                        (let ([m (regexp-match #rx"^(.*)\\.[^.]*$" word)])
>> -                          (let ([short-name (if m (cadr m) word)])
>> -                            (if (string=? short-name "")
>> -                                ""
>> -                                (let ([ms (regexp-match* #rx"-[^-]*" short-name)])
>> -                                  (cond
>> -                                    [(null? ms)
>> -                                     (substring short-name 0 (min 2 (string-length short-name)))]
>> -                                    [else
>> -                                     (apply string-append
>> -                                            (cons (substring short-name 0 1)
>> -                                                  (map (λ (x) (substring x 1 2))
>> -                                                       ms)))])))))]
>> -                       [(long) word]
>> -                       [(very-long)
>> -                        (string-append
>> -                         word
>> -                         ": "
>> -                         (format "~s" require-phases))]))
>> -               last-name])))
>> -
>> -        (super-new)))
>> -
>> -    (define word-snip/lines% (level-mixin (boxed-word-snip-mixin (graph-snip-mixin snip%))))
>> -
>> -    (define draw-lines-pasteboard% (module-overview-pasteboard-mixin
>> -                                    (graph-pasteboard-mixin
>> -                                     pasteboard:basic%)))
>> -    (new draw-lines-pasteboard% [cache-arrow-drawing? #t]))
>> +        (module-overview/file filename parent fill-pasteboard overview-frame%))))
>>
>> +
>> +  (define (_module-overview/file filename parent)
>> +    (module-overview/file filename parent fill-pasteboard overview-frame%))
>> +  (define _make-module-overview-pasteboard make-module-overview-pasteboard)
>>
>>    ;
>>    ;
>> @@ -703,26 +125,7 @@
>>    ;
>>
>>
>> -  (define (module-overview/file filename parent)
>> -    (define progress-eventspace (make-eventspace))
>> -    (define progress-frame (parameterize ([current-eventspace progress-eventspace])
>> -                             (instantiate frame% ()
>> -                               (parent parent)
>> -                               (label progress-label)
>> -                               (width 600))))
>> -    (define progress-message (instantiate message% ()
>> -                               (label "")
>> -                               (stretchable-width #t)
>> -                               (parent progress-frame)))
>> -
>> -    (define thd
>> -      (thread
>> -       (λ ()
>> -         (sleep 2)
>> -         (parameterize ([current-eventspace progress-eventspace])
>> -           (queue-callback
>> -            (λ ()
>> -              (send progress-frame show #t)))))))
>> +  (define (fill-pasteboard pasteboard filename show-status)
>>
>>      (define text/pos
>>        (let ([t (make-object text:basic%)])
>> @@ -732,155 +135,6 @@
>>           0
>>           (send t last-position))))
>>
>> -    (define update-label void)
>> -
>> -    (define (show-status str)
>> -      (parameterize ([current-eventspace progress-eventspace])
>> -        (queue-callback
>> -         (λ ()
>> -           (send progress-message set-label str)))))
>> -
>> -    (define pasteboard (make-module-overview-pasteboard
>> -                        #f
>> -                        (λ (x) (update-label x))))
>> -
>> -    (let ([success? (fill-pasteboard pasteboard text/pos show-status void)])
>> -      (kill-thread thd)
>> -      (parameterize ([current-eventspace progress-eventspace])
>> -        (queue-callback
>> -         (λ ()
>> -           (send progress-frame show #f))))
>> -      (when success?
>> -        (let ()
>> -          (define frame (instantiate overview-frame% ()
>> -                          (label (string-constant module-browser))
>> -                          (width (preferences:get 'drracket:module-overview:window-width))
>> -                          (height (preferences:get 'drracket:module-overview:window-height))
>> -                          (alignment '(left center))))
>> -          (define vp (instantiate vertical-panel% ()
>> -                       (parent (send frame get-area-container))
>> -                       (alignment '(left center))))
>> -          (define root-message (instantiate message% ()
>> -                                 (label
>> -                                  (format (string-constant module-browser-root-filename)
>> -                                          filename))
>> -                                 (parent vp)
>> -                                 (stretchable-width #t)))
>> -          (define label-message (instantiate message% ()
>> -                                  (label "")
>> -                                  (parent vp)
>> -                                  (stretchable-width #t)))
>> -          (define font/label-panel (new horizontal-panel%
>> -                                        [parent vp]
>> -                                        [stretchable-height #f]))
>> -          (define font-size-gauge
>> -            (instantiate slider% ()
>> -              (label font-size-gauge-label)
>> -              (min-value 1)
>> -              (max-value 72)
>> -              (init-value (preferences:get 'drracket:module-overview:label-font-size))
>> -              (parent font/label-panel)
>> -              (callback
>> -               (λ (x y)
>> -                 (send pasteboard set-label-font-size (send font-size-gauge get-value))))))
>> -          (define module-browser-name-length-choice
>> -            (new choice%
>> -                 (parent font/label-panel)
>> -                 (label (string-constant module-browser-name-length))
>> -                 (choices (list (string-constant module-browser-name-long)
>> -                                (string-constant module-browser-name-very-long)))
>> -                 (selection (case (preferences:get 'drracket:module-browser:name-length)
>> -                              [(0) 0]
>> -                              [(1) 0]
>> -                              [(2) 0]
>> -                              [(3) 1]))
>> -                 (callback
>> -                  (λ (x y)
>> -                    ;; note: the preference drracket:module-browser:name-length is also used for
>> -                    ;; the View|Show Module Browser version of the module browser
>> -                    ;; here we just treat any pref value except '3' as if it were for the long names.
>> -                    (let ([selection (send module-browser-name-length-choice get-selection)])
>> -                      (preferences:set 'drracket:module-browser:name-length (+ 2 selection))
>> -                      (send pasteboard set-name-length
>> -                            (case selection
>> -                              [(0) 'long]
>> -                              [(1) 'very-long])))))))
>> -
>> -          (define lib-paths-checkbox
>> -            (instantiate check-box% ()
>> -              (label lib-paths-checkbox-constant)
>> -              (parent vp)
>> -              (callback
>> -               (λ (x y)
>> -                 (if (send lib-paths-checkbox get-value)
>> -                     (send pasteboard show-visible-paths 'lib)
>> -                     (send pasteboard remove-visible-paths 'lib))))))
>> -
>> -          (define ec (make-object canvas:basic% vp pasteboard))
>> -
>> -          (define search-hp (new horizontal-panel% [parent vp] [stretchable-height #f]))
>> -          (define search-tf
>> -            (new text-field%
>> -                 [label (string-constant module-browser-highlight)]
>> -                 [parent search-hp]
>> -                 [callback
>> -                  (λ (tf evt)
>> -                    (define val (send tf get-value))
>> -                    (define reg (and (not (string=? val ""))
>> -                                     (regexp (regexp-quote (send tf get-value)))))
>> -                    (update-found-and-search-hits reg))]))
>> -          (define search-hits (new message% [parent search-hp] [label ""] [auto-resize #t]))
>> -          (define (update-found-and-search-hits reg)
>> -            (send pasteboard begin-edit-sequence)
>> -            (define count 0)
>> -            (define phases (set))
>> -            (let loop ([snip (send pasteboard find-first-snip)])
>> -              (when snip
>> -                (when (is-a? snip boxed-word-snip<%>)
>> -                  (define found?
>> -                    (and reg (regexp-match reg (path->string (send snip get-filename)))))
>> -                  (when (or (not reg) found?)
>> -                    (for ([phase (in-list (send snip get-require-phases))])
>> -                      (set! phases (set-add phases phase)))
>> -                    (set! count (+ count 1)))
>> -                  (send snip set-found! found?))
>> -                (loop (send snip next))))
>> -
>> -            (send search-hits set-label
>> -                  (string-append
>> -                   (if reg
>> -                       (format "~a found" count)
>> -                       (format "~a total" count))
>> -                   (render-phases phases)))
>> -            (send pasteboard end-edit-sequence))
>> -          (update-found-and-search-hits #f) ;; only to initialize search-hits
>> -
>> -          (send lib-paths-checkbox set-value
>> -                (not (memq 'lib (preferences:get 'drracket:module-browser:hide-paths))))
>> -          (set! update-label
>> -                (λ (s)
>> -                  (if (and s (not (null? s)))
>> -                      (let* ([currently-over (car s)]
>> -                             [fn (send currently-over get-filename)]
>> -                             [lines (send currently-over get-lines)])
>> -                        (when (and fn lines)
>> -                          (send label-message set-label
>> -                                (format filename-constant fn lines))))
>> -                      (send label-message set-label ""))))
>> -
>> -          (send pasteboard set-name-length
>> -                (case (preferences:get 'drracket:module-browser:name-length)
>> -                  [(0) 'long]
>> -                  [(1) 'long]
>> -                  [(2) 'long]
>> -                  [(3) 'very-long]))
>> -          ;; shouldn't be necessary here -- need to find callback on editor
>> -          (send pasteboard render-snips)
>> -
>> -          (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))
>>
>> @@ -978,7 +232,6 @@
>>       complete-program?)
>>
>>      (semaphore-wait init-complete)
>> -    (send-user-thread/eventspace user-thread user-custodian)
>>
>>      ;; this thread puts a "cap" on the end of the connection-channel
>>      ;; so that we know when we've gotten to the end.
>> @@ -1041,7 +294,7 @@
>>          (preferences:set 'drracket:module-overview:window-width w)
>>          (preferences:set 'drracket:module-overview:window-height h)
>>          (super on-size w h))
>> -      (super-instantiate ()))))
>> +      (super-new))))
>>
>>  (define/contract (render-phases s)
>>    (-> (set/c (or/c exact-integer? #f)) string?)
>> @@ -1181,7 +434,6 @@
>>      (match fn/submod
>>        [(? path?) (add-module-code-connections fn/submod (get-module-code fn/submod))]
>>        [`(submod ,filename ,sub-mods ...)
>> -       (printf "looking in submods: ~s\n" sub-mods)
>>         (add-module-code-connections
>>          fn/submod
>>          (get-module-code filename #:submodule-path sub-mods))]))
>> @@ -1247,9 +499,7 @@
>>    (define (to-path r-mpi)
>>      (match r-mpi
>>        [(? path? p) p]
>> -      [`(submod ,(? path? p) ,_ ...)
>> -       (printf "aha! ~s\n" p)
>> -       p]
>> +      [`(submod ,(? path? p) ,_ ...) p]
>>        [_ #f]))
>>
>>    (define (get-key dr requiring-libroot required)
>> @@ -1263,3 +513,872 @@
>>             (cond [(symbol? a) 'lib]
>>                   [(pair? a) (and (symbol? (car a)) (car a))]
>>                   [else #f])))))
>> +
>> +(define (standalone-module-overview/file filename)
>> +  (module-overview/file filename #f standalone-fill-pasteboard frame:basic%))
>> +
>> +(define (module-overview/file filename parent fill-pasteboard overview-frame%)
>> +  (define progress-eventspace (make-eventspace))
>> +  (define progress-frame (parameterize ([current-eventspace progress-eventspace])
>> +                           (instantiate frame% ()
>> +                             (parent parent)
>> +                             (label progress-label)
>> +                             (width 600))))
>> +  (define progress-message (instantiate message% ()
>> +                             (label "")
>> +                             (stretchable-width #t)
>> +                             (parent progress-frame)))
>> +
>> +  (define thd
>> +    (thread
>> +     (λ ()
>> +       (sleep 2)
>> +       (parameterize ([current-eventspace progress-eventspace])
>> +         (queue-callback
>> +          (λ ()
>> +            (send progress-frame show #t)))))))
>> +
>> +
>> +  (define update-label void)
>> +
>> +  (define (show-status str)
>> +    (parameterize ([current-eventspace progress-eventspace])
>> +      (queue-callback
>> +       (λ ()
>> +         (send progress-message set-label str)))))
>> +
>> +  (define pasteboard (make-module-overview-pasteboard
>> +                      #f
>> +                      (λ (x) (update-label x))))
>> +
>> +  (let ([success? (fill-pasteboard pasteboard filename show-status)])
>> +    (kill-thread thd)
>> +    (parameterize ([current-eventspace progress-eventspace])
>> +      (queue-callback
>> +       (λ ()
>> +         (send progress-frame show #f))))
>> +    (when success?
>> +      (let ()
>> +        (define frame (new overview-frame%
>> +                           [label (string-constant module-browser)]
>> +                           [width (preferences:get 'drracket:module-overview:window-width)]
>> +                           [height (preferences:get 'drracket:module-overview:window-height)]
>> +                           [alignment '(left center)]))
>> +        (define vp (instantiate vertical-panel% ()
>> +                     (parent (send frame get-area-container))
>> +                     (alignment '(left center))))
>> +        (define root-message (instantiate message% ()
>> +                               (label
>> +                                (format (string-constant module-browser-root-filename)
>> +                                        filename))
>> +                               (parent vp)
>> +                               (stretchable-width #t)))
>> +        (define label-message (instantiate message% ()
>> +                                (label "")
>> +                                (parent vp)
>> +                                (stretchable-width #t)))
>> +        (define font/label-panel (new horizontal-panel%
>> +                                      [parent vp]
>> +                                      [stretchable-height #f]))
>> +        (define font-size-gauge
>> +          (instantiate slider% ()
>> +            (label font-size-gauge-label)
>> +            (min-value 1)
>> +            (max-value 72)
>> +            (init-value (preferences:get 'drracket:module-overview:label-font-size))
>> +            (parent font/label-panel)
>> +            (callback
>> +             (λ (x y)
>> +               (send pasteboard set-label-font-size (send font-size-gauge get-value))))))
>> +        (define module-browser-name-length-choice
>> +          (new choice%
>> +               (parent font/label-panel)
>> +               (label (string-constant module-browser-name-length))
>> +               (choices (list (string-constant module-browser-name-long)
>> +                              (string-constant module-browser-name-very-long)))
>> +               (selection (case (preferences:get 'drracket:module-browser:name-length)
>> +                            [(0) 0]
>> +                            [(1) 0]
>> +                            [(2) 0]
>> +                            [(3) 1]))
>> +               (callback
>> +                (λ (x y)
>> +                  ;; note: the preference drracket:module-browser:name-length is also used for
>> +                  ;; the View|Show Module Browser version of the module browser
>> +                  ;; here we just treat any pref value except '3' as if it were for the long names.
>> +                  (let ([selection (send module-browser-name-length-choice get-selection)])
>> +                    (preferences:set 'drracket:module-browser:name-length (+ 2 selection))
>> +                    (send pasteboard set-name-length
>> +                          (case selection
>> +                            [(0) 'long]
>> +                            [(1) 'very-long])))))))
>> +
>> +        (define lib-paths-checkbox
>> +          (instantiate check-box% ()
>> +            (label lib-paths-checkbox-constant)
>> +            (parent vp)
>> +            (callback
>> +             (λ (x y)
>> +               (if (send lib-paths-checkbox get-value)
>> +                   (send pasteboard show-visible-paths 'lib)
>> +                   (send pasteboard remove-visible-paths 'lib))))))
>> +
>> +        (define ec (make-object canvas:basic% vp pasteboard))
>> +
>> +        (define search-hp (new horizontal-panel% [parent vp] [stretchable-height #f]))
>> +        (define search-tf
>> +          (new text-field%
>> +               [label (string-constant module-browser-highlight)]
>> +               [parent search-hp]
>> +               [callback
>> +                (λ (tf evt)
>> +                  (define val (send tf get-value))
>> +                  (define reg (and (not (string=? val ""))
>> +                                   (regexp (regexp-quote (send tf get-value)))))
>> +                  (update-found-and-search-hits reg))]))
>> +        (define search-hits (new message% [parent search-hp] [label ""] [auto-resize #t]))
>> +        (define (update-found-and-search-hits reg)
>> +          (send pasteboard begin-edit-sequence)
>> +          (define count 0)
>> +          (define phases (set))
>> +          (let loop ([snip (send pasteboard find-first-snip)])
>> +            (when snip
>> +              (when (is-a? snip boxed-word-snip<%>)
>> +                (define found?
>> +                  (and reg (regexp-match reg (path->string (send snip get-filename)))))
>> +                (when (or (not reg) found?)
>> +                  (for ([phase (in-list (send snip get-require-phases))])
>> +                    (set! phases (set-add phases phase)))
>> +                  (set! count (+ count 1)))
>> +                (send snip set-found! found?))
>> +              (loop (send snip next))))
>> +
>> +          (send search-hits set-label
>> +                (string-append
>> +                 (if reg
>> +                     (format "~a found" count)
>> +                     (format "~a total" count))
>> +                 (render-phases phases)))
>> +          (send pasteboard end-edit-sequence))
>> +        (update-found-and-search-hits #f) ;; only to initialize search-hits
>> +
>> +        (send lib-paths-checkbox set-value
>> +              (not (memq 'lib (preferences:get 'drracket:module-browser:hide-paths))))
>> +        (set! update-label
>> +              (λ (s)
>> +                (if (and s (not (null? s)))
>> +                    (let* ([currently-over (car s)]
>> +                           [fn (send currently-over get-filename)]
>> +                           [lines (send currently-over get-lines)])
>> +                      (when (and fn lines)
>> +                        (send label-message set-label
>> +                              (format filename-constant fn lines))))
>> +                    (send label-message set-label ""))))
>> +
>> +        (send pasteboard set-name-length
>> +              (case (preferences:get 'drracket:module-browser:name-length)
>> +                [(0) 'long]
>> +                [(1) 'long]
>> +                [(2) 'long]
>> +                [(3) 'very-long]))
>> +        ;; shouldn't be necessary here -- need to find callback on editor
>> +        (send pasteboard render-snips)
>> +
>> +        (send frame show #t)))))
>> +
>> +;; make-module-overview-pasteboard : boolean
>> +;;                                   ((union #f snip) -> void)
>> +;;                                -> (union string pasteboard)
>> +;; string as result indicates an error message
>> +;; pasteboard as result is the pasteboard to show
>> +(define (make-module-overview-pasteboard vertical? mouse-currently-over)
>> +
>> +  (define level-ht (make-hasheq))
>> +
>> +  ;; 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 "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))
>> +  (define light-syntax-pen (send the-pen-list find-or-create-pen "plum" 1 'solid))
>> +  (define light-syntax-brush (send the-brush-list find-or-create-brush "plum" 'solid))
>> +
>> +  (define dark-template-pen (send the-pen-list find-or-create-pen "seagreen" 1 'solid))
>> +  (define dark-template-brush (send the-brush-list find-or-create-brush "seagreen" 'solid))
>> +  (define light-template-pen (send the-pen-list find-or-create-pen "springgreen" 1 'solid))
>> +  (define light-template-brush (send the-brush-list find-or-create-brush "springgreen" 'solid))
>> +
>> +  (define dark-pen (send the-pen-list find-or-create-pen "blue" 1 'solid))
>> +  (define dark-brush (send the-brush-list find-or-create-brush "blue" 'solid))
>> +  (define light-pen (send the-pen-list find-or-create-pen "light blue" 1 'solid))
>> +  (define light-brush (send the-brush-list find-or-create-brush "light blue" 'solid))
>> +
>> +  (define (module-overview-pasteboard-mixin %)
>> +    (class* % (module-overview-pasteboard<%>)
>> +
>> +      (inherit get-snip-location
>> +               begin-edit-sequence
>> +               end-edit-sequence
>> +               insert
>> +               move-to
>> +               find-first-snip
>> +               dc-location-to-editor-location
>> +               find-snip
>> +               get-canvas)
>> +
>> +      ;; require-depth-ht : hash[(list snip snip) -o> (listof integer)]
>> +      ;; maps parent/child snips (ie, those that match up to modules
>> +      ;; that require each other) to phase differences
>> +      (define require-depth-ht (make-hash))
>> +
>> +      (define name-length 'long)
>> +      (define/public (set-name-length nl)
>> +        (unless (eq? name-length nl)
>> +          (set! name-length nl)
>> +          (re-add-snips)
>> +          (render-snips)))
>> +      (define/public (get-name-length) name-length)
>> +
>> +      (field [max-lines #f])
>> +
>> +      ;; controls if the snips should be moved
>> +      ;; around when the font size is changed.
>> +      ;; set to #f if the user ever moves a
>> +      ;; snip themselves.
>> +      (define dont-move-snips #f)
>> +
>> +      (field (label-font-size (preferences:get 'drracket:module-overview:label-font-size)))
>> +      (define/public (get-label-font-size) label-font-size)
>> +      (define/private (get-snip-hspace) (if vertical?
>> +                                            2
>> +                                            (* 2 label-font-size)))
>> +      (define/private (get-snip-vspace) (if vertical?
>> +                                            30
>> +                                            2))
>> +      (define snip-height #f)
>> +
>> +      (define font-label-size-callback-running? #f)
>> +      (define new-font-size #f)
>> +      (define/public (set-label-font-size size-to-set)
>> +        (set! new-font-size size-to-set)
>> +        (unless font-label-size-callback-running?
>> +          (set! font-label-size-callback-running? #t)
>> +          (queue-callback
>> +           (λ ()
>> +             (set! label-font-size new-font-size)
>> +             (preferences:set 'drracket:module-overview:label-font-size
>> +                              new-font-size)
>> +             (set! label-font (find-label-font label-font-size))
>> +             (begin-edit-sequence)
>> +             (let loop ([snip (find-first-snip)])
>> +               (when snip
>> +                 (let ([admin (send snip get-admin)])
>> +                   (when admin
>> +                     (send admin resized snip #t)))
>> +                 (loop (send snip next))))
>> +             (unless dont-move-snips
>> +               (render-snips))
>> +             (end-edit-sequence)
>> +             (set! new-font-size #f)
>> +             (set! font-label-size-callback-running? #f))
>> +           #f)))
>> +
>> +      (define/public (begin-adding-connections)
>> +        (when max-lines
>> +          (error 'begin-adding-connections
>> +                 "already in begin-adding-connections/end-adding-connections sequence"))
>> +        (set! max-lines 0)
>> +        (begin-edit-sequence)
>> +        (let loop ()
>> +          (let ([s (find-first-snip)])
>> +            (when s
>> +              (send s release-from-owner)
>> +              (loop))))
>> +        (set! level-ht (make-hasheq))
>> +        (set! snip-table (make-hash)))
>> +
>> +      (define/public (end-adding-connections)
>> +        (unless max-lines
>> +          (error 'end-adding-connections
>> +                 "not in begin-adding-connections/end-adding-connections sequence"))
>> +
>> +        (unless (zero? max-lines)
>> +          (let loop ([snip (find-first-snip)])
>> +            (when snip
>> +              (when (is-a? snip word-snip/lines%)
>> +                (send snip normalize-lines max-lines))
>> +              (loop (send snip next)))))
>> +
>> +
>> +        (set! max-lines #f)
>> +        (compute-snip-require-phases)
>> +        (remove-specially-linked)
>> +        (render-snips)
>> +        (end-edit-sequence))
>> +
>> +      (define/private (compute-snip-require-phases)
>> +        (let ([ht (make-hash)]) ;; avoid infinite loops
>> +          (for ([snip (in-list (get-top-most-snips))])
>> +            (let loop ([parent snip]
>> +                       [depth 0])    ;; depth is either an integer or #f (indicating for-label)
>> +              (unless (hash-ref ht (cons parent depth) #f)
>> +                (hash-set! ht (cons parent depth) #t)
>> +                (send parent add-require-phase depth)
>> +                (for ([child (in-list (send parent get-children))])
>> +                  (for ([delta-depth (in-list (hash-ref require-depth-ht (list parent child)))])
>> +                    (loop child
>> +                          (and depth delta-depth (+ delta-depth depth))))))))))
>> +
>> +      ;; add-connection : path/string/submod path/string/submod (union symbol #f) number -> 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/public (add-connection name-original name-require path-key require-depth)
>> +        (unless max-lines
>> +          (error 'add-connection "not in begin-adding-connections/end-adding-connections sequence"))
>> +        (let* ([original-snip (find/create-snip name-original)]
>> +               [require-snip (find/create-snip name-require)]
>> +               [original-level (send original-snip get-level)]
>> +               [require-level (send require-snip get-level)])
>> +          (let ([require-depth-key (list original-snip require-snip)])
>> +            (hash-set! require-depth-ht
>> +                       require-depth-key
>> +                       (cons require-depth (hash-ref require-depth-ht require-depth-key '()))))
>> +          (case require-depth
>> +            [(0)
>> +             (add-links original-snip require-snip
>> +                        dark-pen light-pen
>> +                        dark-brush light-brush)]
>> +            [else
>> +             (add-links original-snip require-snip
>> +                        dark-syntax-pen light-syntax-pen
>> +                        dark-syntax-brush light-syntax-brush)])
>> +          (when path-key
>> +            (send original-snip add-special-key-child path-key require-snip))
>> +          (if (send original-snip get-level)
>> +              (fix-snip-level require-snip (+ original-level 1))
>> +              (fix-snip-level original-snip 0))))
>> +
>> +      ;; fix-snip-level : snip number -> void
>> +      ;; moves the snip (and any children) to at least `new-level'
>> +      ;; doesn't move them if they are already past that level
>> +      (define/private (fix-snip-level snip new-min-level)
>> +        (let loop ([snip snip]
>> +                   [new-min-level new-min-level])
>> +          (let ([current-level (send snip get-level)])
>> +            (when (or (not current-level)
>> +                      (new-min-level . > . current-level))
>> +              (send snip set-level new-min-level)
>> +              (for-each
>> +               (λ (child) (loop child (+ new-min-level 1)))
>> +               (send snip get-children))))))
>> +
>> +      ;; find/create-snip : (union path string) boolean? -> word-snip/lines
>> +      ;; finds the snip with this key, or creates a new
>> +      ;; ones. For the same key, always returns the same snip.
>> +      ;; uses snip-table as a cache for this purpose.
>> +      (define/private (find/create-snip name)
>> +        (define filename
>> +          (match name
>> +            [(? path-string?) (and (file-exists? name) name)]
>> +            [`(submod ,p ,_ ...) (and (file-exists? p) p)]
>> +            [else #f]))
>> +        (hash-ref
>> +         snip-table
>> +         name
>> +         (λ ()
>> +           (define snip
>> +             (new word-snip/lines%
>> +                  [lines (if filename (count-lines filename) #f)]
>> +                  [word
>> +                   (if filename
>> +                       (let ([short-name (let-values ([(_1 name _2) (split-path filename)])
>> +                                           (path->string name))])
>> +                         (match name
>> +                           [(? path-string?) short-name]
>> +                           [`(submod ,p ,submods ...)
>> +                            (format "~s" `(submod ,short-name , at submods))]))
>> +                       (format "~a" name))]
>> +                  [pb this]
>> +                  [filename filename]))
>> +           (insert snip)
>> +           (hash-set! snip-table name snip)
>> +           snip)))
>> +
>> +      ;; count-lines : string[filename] -> (union #f number)
>> +      ;; effect: updates max-lines
>> +      (define/private (count-lines filename)
>> +        (let ([lines
>> +               (call-with-input-file filename
>> +                 (λ (port)
>> +                   (let loop ([n 0])
>> +                     (let ([l (read-line port)])
>> +                       (if (eof-object? l)
>> +                           n
>> +                           (loop (+ n 1))))))
>> +                 #:mode 'text)])
>> +          (set! max-lines (max lines max-lines))
>> +          lines))
>> +
>> +      ;; get-snip-width : snip -> number
>> +      ;; exracts the width of a snip
>> +      (define/private (get-snip-width snip)
>> +        (let ([lb (box 0)]
>> +              [rb (box 0)])
>> +          (get-snip-location snip lb #f #f)
>> +          (get-snip-location snip rb #f #t)
>> +          (- (unbox rb)
>> +             (unbox lb))))
>> +
>> +      ;; get-snip-height : snip -> number
>> +      ;; exracts the width of a snip
>> +      (define/private (get-snip-height snip)
>> +        (let ([tb (box 0)]
>> +              [bb (box 0)])
>> +          (get-snip-location snip #f tb #f)
>> +          (get-snip-location snip #f bb #t)
>> +          (- (unbox bb)
>> +             (unbox tb))))
>> +
>> +      (field [hidden-paths (preferences:get 'drracket:module-browser:hide-paths)])
>> +      (define/public (remove-visible-paths symbol)
>> +        (unless (memq symbol hidden-paths)
>> +          (set! hidden-paths (cons symbol hidden-paths))
>> +          (refresh-visible-paths)))
>> +      (define/public (show-visible-paths symbol)
>> +        (when (memq symbol hidden-paths)
>> +          (set! hidden-paths (remq symbol hidden-paths))
>> +          (refresh-visible-paths)))
>> +      (define/public (get-hidden-paths) hidden-paths)
>> +
>> +      (define/private (refresh-visible-paths)
>> +        (begin-edit-sequence)
>> +        (re-add-snips)
>> +        (render-snips)
>> +        (end-edit-sequence))
>> +
>> +      (define/private (re-add-snips)
>> +        (begin-edit-sequence)
>> +        (remove-specially-linked)
>> +        (end-edit-sequence))
>> +
>> +      (define/private (remove-specially-linked)
>> +        (remove-currrently-inserted)
>> +        (cond
>> +          [(null? hidden-paths)
>> +           (add-all)]
>> +          [else
>> +           (let ([ht (make-hasheq)])
>> +             (for ([snip (in-list (get-top-most-snips))])
>> +               (insert snip)
>> +               (let loop ([snip snip])
>> +                 (unless (hash-ref ht snip #f)
>> +                   (hash-set! ht snip #t)
>> +                   (for ([child (in-list (send snip get-children))])
>> +                     (unless (ormap (λ (key) (send snip is-special-key-child?
>> +                                                   key child))
>> +                                    hidden-paths)
>> +                       (insert child)
>> +                       (loop child)))))))]))
>> +
>> +      (define/private (remove-currrently-inserted)
>> +        (let loop ()
>> +          (let ([snip (find-first-snip)])
>> +            (when snip
>> +              (send snip release-from-owner)
>> +              (loop)))))
>> +
>> +      (define/private (add-all)
>> +        (let ([ht (make-hasheq)])
>> +          (for-each
>> +           (λ (snip)
>> +             (let loop ([snip snip])
>> +               (unless (hash-ref ht snip (λ () #f))
>> +                 (hash-set! ht snip #t)
>> +                 (insert snip)
>> +                 (for-each loop (send snip get-children)))))
>> +           (get-top-most-snips))))
>> +
>> +      (define/private (get-top-most-snips) (hash-ref level-ht 0 (λ () null)))
>> +
>> +      ;; render-snips : -> void
>> +      (define/public (render-snips)
>> +        (begin-edit-sequence)
>> +        (let ([max-minor 0])
>> +
>> +          ;; major-dim is the dimension that new levels extend along
>> +          ;; minor-dim is the dimension that snips inside a level extend along
>> +
>> +          (hash-for-each
>> +           level-ht
>> +           (λ (n v)
>> +             (set! max-minor (max max-minor (apply + (map (if vertical?
>> +                                                              (λ (x) (get-snip-width x))
>> +                                                              (λ (x) (get-snip-height x)))
>> +                                                          v))))))
>> +
>> +          (let ([levels (sort (hash-map level-ht list)
>> +                              (λ (x y) (<= (car x) (car y))))])
>> +            (let loop ([levels levels]
>> +                       [major-dim 0])
>> +              (cond
>> +                [(null? levels) (void)]
>> +                [else
>> +                 (let* ([level (car levels)]
>> +                        [n (car level)]
>> +                        [this-level-snips (cadr level)]
>> +                        [this-minor (apply + (map (if vertical?
>> +                                                      (λ (x) (get-snip-width x))
>> +                                                      (λ (x) (get-snip-height x)))
>> +                                                  this-level-snips))]
>> +                        [this-major (apply max (map (if vertical?
>> +                                                        (λ (x) (get-snip-height x))
>> +                                                        (λ (x) (get-snip-width x)))
>> +                                                    this-level-snips))])
>> +                   (let loop ([snips this-level-snips]
>> +                              [minor-dim (/ (- max-minor this-minor) 2)])
>> +                     (unless (null? snips)
>> +                       (let* ([snip (car snips)]
>> +                              [new-major-coord
>> +                               (+ major-dim
>> +                                  (floor
>> +                                   (- (/ this-major 2)
>> +                                      (/ (if vertical?
>> +                                             (get-snip-height snip)
>> +                                             (get-snip-width snip))
>> +                                         2))))])
>> +                         (if vertical?
>> +                             (move-to snip minor-dim new-major-coord)
>> +                             (move-to snip new-major-coord minor-dim))
>> +                         (loop (cdr snips)
>> +                               (+ minor-dim
>> +                                  (if vertical?
>> +                                      (get-snip-hspace)
>> +                                      (get-snip-vspace))
>> +                                  (if vertical?
>> +                                      (get-snip-width snip)
>> +                                      (get-snip-height snip)))))))
>> +                   (loop (cdr levels)
>> +                         (+ major-dim
>> +                            (if vertical?
>> +                                (get-snip-vspace)
>> +                                (get-snip-hspace))
>> +                            this-major)))]))))
>> +        (end-edit-sequence))
>> +
>> +      (define/override (on-mouse-over-snips snips)
>> +        (mouse-currently-over snips))
>> +
>> +      (define/override (on-double-click snip event)
>> +        (cond
>> +          [(is-a? snip boxed-word-snip<%>)
>> +           (let ([fn (send snip get-filename)])
>> +             (when fn
>> +               (handler:edit-file fn)))]
>> +          [else (super on-double-click snip event)]))
>> +
>> +      (define/override (on-event evt)
>> +        (cond
>> +          [(send evt button-down? 'right)
>> +           (let ([ex (send evt get-x)]
>> +                 [ey (send evt get-y)])
>> +             (let-values ([(x y) (dc-location-to-editor-location ex ey)])
>> +               (let ([snip (find-snip x y)]
>> +                     [canvas (get-canvas)])
>> +                 (let ([right-button-menu (make-object popup-menu%)])
>> +                   (when (and snip
>> +                              (is-a? snip boxed-word-snip<%>)
>> +                              canvas
>> +                              (send snip get-filename))
>> +                     (instantiate menu-item% ()
>> +                       (label
>> +                        (trim-string
>> +                         (format open-file-format
>> +                                 (path->string (send snip get-filename)))
>> +                         200))
>> +                       (parent right-button-menu)
>> +                       (callback
>> +                        (λ (x y)
>> +                          (handler:edit-file
>> +                           (send snip get-filename))))))
>> +                   (instantiate menu-item% ()
>> +                     (label (string-constant module-browser-open-all))
>> +                     (parent right-button-menu)
>> +                     (callback
>> +                      (λ (x y)
>> +                        (let loop ([snip (find-first-snip)])
>> +                          (when snip
>> +                            (when (is-a? snip boxed-word-snip<%>)
>> +                              (let ([filename (send snip get-filename)])
>> +                                (handler:edit-file filename)))
>> +                            (loop (send snip next)))))))
>> +                   (send canvas popup-menu
>> +                         right-button-menu
>> +                         (+ (send evt get-x) 1)
>> +                         (+ (send evt get-y) 1))))))]
>> +          [else (super on-event evt)]))
>> +
>> +      (super-new)))
>> +
>> +  (define (trim-string str len)
>> +    (cond
>> +      [(<= (string-length str) len) str]
>> +      [else (substring str (- (string-length str) len) (string-length str))]))
>> +
>> +  (define (level-mixin %)
>> +    (class %
>> +      (field (level #f))
>> +      (define/public (get-level) level)
>> +      (define/public (set-level _l)
>> +        (when level
>> +          (hash-set! level-ht level
>> +                     (remq this (hash-ref level-ht level))))
>> +        (set! level _l)
>> +        (hash-set! level-ht level
>> +                   (cons this (hash-ref level-ht level (λ () null)))))
>> +
>> +      (super-instantiate ())))
>> +
>> +  (define (boxed-word-snip-mixin %)
>> +    (class* % (boxed-word-snip<%>)
>> +      (init-field word
>> +                  filename
>> +                  lines
>> +                  pb)
>> +
>> +      (inherit get-admin)
>> +
>> +      (define require-phases '())
>> +      (define/public (get-require-phases) require-phases)
>> +      (define/public (add-require-phase d)
>> +        (unless (member d require-phases)
>> +          (set! last-name #f)
>> +          (set! last-size #f)
>> +          (set! require-phases (sort (cons d require-phases) < #:key (λ (x) (or x +inf.0))))))
>> +
>> +      (field [special-children (make-hasheq)])
>> +      (define/public (is-special-key-child? key child)
>> +        (let ([ht (hash-ref special-children key #f)])
>> +          (and ht (hash-ref ht child #f))))
>> +      (define/public (add-special-key-child key child)
>> +        (hash-set! (hash-ref! special-children key make-hasheq) child #t))
>> +
>> +      (define/public (get-filename) filename)
>> +      (define/public (get-word) word)
>> +      (define/public (get-lines) lines)
>> +
>> +      (field (lines-brush #f))
>> +      (define/public (normalize-lines n)
>> +        (if lines
>> +            (let* ([grey (inexact->exact (floor (- 255 (* 255 (sqrt (/ lines n))))))])
>> +              (set! lines-brush (send the-brush-list find-or-create-brush
>> +                                      (make-object color% grey grey grey)
>> +                                      'solid)))
>> +            (set! lines-brush (send the-brush-list find-or-create-brush
>> +                                    "salmon"
>> +                                    'solid))))
>> +
>> +      (define snip-width 0)
>> +      (define snip-height 0)
>> +
>> +      (define/override (get-extent dc x y wb hb descent space lspace rspace)
>> +        (cond
>> +          [(equal? (name->label) "")
>> +           (set! snip-width 15)
>> +           (set! snip-height 15)]
>> +          [else
>> +           (let-values ([(w h a d) (send dc get-text-extent (name->label) label-font)])
>> +             (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)
>> +        (set-box/f space 0)
>> +        (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-pen (send dc get-pen)])
>> +          (send dc set-font label-font)
>> +          (cond
>> +            [found-highlight?
>> +             (send dc set-brush search-result-background 'solid)]
>> +            [lines-brush
>> +             (send dc set-brush lines-brush)])
>> +          (when (rectangles-intersect? left top right bottom
>> +                                       x y (+ x snip-width) (+ y snip-height))
>> +            (send dc draw-rectangle x y snip-width snip-height)
>> +            (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)))
>> +
>> +      ;; name->label : path -> string
>> +      ;; constructs a label for the little boxes in terms
>> +      ;; of the filename.
>> +
>> +      (define last-name #f)
>> +      (define last-size #f)
>> +
>> +      (define/private (name->label)
>> +        (let ([this-size (send pb get-name-length)])
>> +          (cond
>> +            [(eq? this-size last-size) last-name]
>> +            [else
>> +             (set! last-size this-size)
>> +             (set! last-name
>> +                   (case last-size
>> +                     [(short)
>> +                      (if (string=? word "")
>> +                          ""
>> +                          (string (string-ref word 0)))]
>> +                     [(medium)
>> +                      (let ([m (regexp-match #rx"^(.*)\\.[^.]*$" word)])
>> +                        (let ([short-name (if m (cadr m) word)])
>> +                          (if (string=? short-name "")
>> +                              ""
>> +                              (let ([ms (regexp-match* #rx"-[^-]*" short-name)])
>> +                                (cond
>> +                                  [(null? ms)
>> +                                   (substring short-name 0 (min 2 (string-length short-name)))]
>> +                                  [else
>> +                                   (apply string-append
>> +                                          (cons (substring short-name 0 1)
>> +                                                (map (λ (x) (substring x 1 2))
>> +                                                     ms)))])))))]
>> +                     [(long) word]
>> +                     [(very-long)
>> +                      (string-append
>> +                       word
>> +                       ": "
>> +                       (format "~s" require-phases))]))
>> +             last-name])))
>> +
>> +      (super-new)))
>> +
>> +  (define word-snip/lines% (level-mixin (boxed-word-snip-mixin (graph-snip-mixin snip%))))
>> +
>> +  (define draw-lines-pasteboard% (module-overview-pasteboard-mixin
>> +                                  (graph-pasteboard-mixin
>> +                                   pasteboard:basic%)))
>> +  (new draw-lines-pasteboard% [cache-arrow-drawing? #t]))
>> +
>> +(define (standalone-fill-pasteboard pasteboard filename show-status)
>> +  (define progress-channel (make-async-channel))
>> +  (define connection-channel (make-async-channel))
>> +
>> +  (define-values/invoke-unit process-program-unit
>> +    (import process-program-import^)
>> +    (export process-program-export^))
>> +
>> +  (define user-custodian (make-custodian))
>> +  (define error-str #f)
>> +
>> +  (define init-dir (get-init-dir filename))
>> +
>> +  (define (swallow-specials port)
>> +    (define-values (in out) (make-pipe-with-specials))
>> +    (thread
>> +     (λ ()
>> +       (let loop ()
>> +         (define c (read-char-or-special in))
>> +         (cond
>> +           [(char? c)
>> +            (display c out)
>> +            (loop)]
>> +           [(eof-object? c)
>> +            (close-output-port out)
>> +            (close-input-port in)]
>> +           [else
>> +            (loop)]))))
>> +    out)
>> +
>> +  (define done-chan (make-channel))
>> +
>> +  (define user-thread
>> +    (parameterize ([current-custodian user-custodian])
>> +
>> +      ;; not that we expect anyone to really use this, but
>> +      ;; we make it here to avoid the expanded code from interfereing
>> +      ;; with the module browser
>> +      (parameterize ([current-eventspace (make-eventspace)])
>> +
>> +        (thread
>> +         (λ ()
>> +           (moddep-current-open-input-file
>> +            (λ (filename)
>> +              (let* ([p (open-input-file filename)]
>> +                     [wxme? (regexp-match-peek #rx#"^WXME" p)])
>> +                (if wxme?
>> +                    (let ([t (new text%)])
>> +                      (close-input-port p)
>> +                      (send t load-file filename)
>> +                      (let ([prt (open-input-text-editor t)])
>> +                        (port-count-lines! prt)
>> +                        prt))
>> +                    p))))
>> +           (current-load-relative-directory #f)
>> +           (current-directory init-dir)
>> +           (add-connections (if (string? filename)
>> +                                (string->path filename)
>> +                                filename))
>> +           (channel-put done-chan #t))))))
>> +
>> +  (send pasteboard begin-adding-connections)
>> +  (let ([evt
>> +         (choice-evt
>> +          (handle-evt progress-channel (λ (x) (cons 'progress x)))
>> +          (handle-evt connection-channel (λ (x) (cons 'connect x)))
>> +          (handle-evt done-chan (λ (x) (cons 'done #f)))
>> +          (handle-evt user-thread (λ (x) (cons 'died #f))))])
>> +    (let loop ()
>> +      (define evt-value (yield evt))
>> +      (define key (car evt-value))
>> +      (define val (cdr evt-value))
>> +      (case key
>> +        [(done) (void)]
>> +        [(died) (exit)]
>> +        [(progress)
>> +         (show-status val)
>> +         (loop)]
>> +        [(connect)
>> +         (define name-original (list-ref val 0))
>> +         (define name-require (list-ref val 1))
>> +         (define path-key (list-ref val 2))
>> +         (define require-depth (list-ref val 3))
>> +         (send pasteboard add-connection name-original name-require path-key require-depth)
>> +         (loop)])))
>> +  (send pasteboard end-adding-connections)
>> +
>> +  (custodian-shutdown-all user-custodian)
>> +
>> +  (cond
>> +    [error-str
>> +     (message-box
>> +      (string-constant module-browser)
>> +      (format (string-constant module-browser-error-expanding)
>> +              error-str))
>> +     #f]
>> +    [else
>> +     #t]))
>>
>> pkgs/drracket-pkgs/drracket/drracket/private/standalone-module-browser.rkt
>> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
>> --- /dev/null
>> +++ NEW/pkgs/drracket-pkgs/drracket/drracket/private/standalone-module-browser.rkt
>> @@ -0,0 +1,10 @@
>> +#lang racket/base
>> +(require racket/cmdline racket/runtime-path)
>> +
>> +(define file (command-line #:args (file) file))
>> +
>> +(define-runtime-path module-browser.rkt "module-browser.rkt")
>> +(define standalone-module-overview/file
>> +  (dynamic-require module-browser.rkt 'standalone-module-overview/file))
>> +
>> +(standalone-module-overview/file file)
>>
>> pkgs/drracket-pkgs/drracket/drracket/private/unit.rkt
>> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
>> --- OLD/pkgs/drracket-pkgs/drracket/drracket/private/unit.rkt
>> +++ NEW/pkgs/drracket-pkgs/drracket/drracket/private/unit.rkt
>> @@ -5342,4 +5342,3 @@
>>          (check-true (string?
>>                       (compute-label-string
>>                        (string->path (make-string i #\x)))))))))
>> -
>>
>> pkgs/string-constants-pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt
>> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
>> --- OLD/pkgs/string-constants-pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt
>> +++ NEW/pkgs/string-constants-pkgs/string-constants-lib/string-constants/private/english-string-constants.rkt
>> @@ -1394,7 +1394,7 @@ please adhere to these guidelines:
>>   (module-browser-filename-format "Full Filename: ~a (~a lines)")
>>   (module-browser-root-filename "Root Filename: ~a")
>>   (module-browser-font-size-gauge-label "Font Size")
>> - (module-browser-progress-label "Module overview progress")
>> + (module-browser-progress-label "Module Browser Progress")
>>   (module-browser-adding-file "Adding file: ~a...")
>>   (module-browser-laying-out-graph-label "Laying out graph")
>>   (module-browser-open-file-format "Open ~a")
>
> ...
>
> [Message clipped]


Posted on the dev mailing list.