[racket-dev] [plt] Push #28525: master branch updated
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
-------------- next part --------------
A non-text attachment was scrubbed...
Name: 0001-Fix-raco-dependencies-graph-on-relative-paths.patch
Type: application/octet-stream
Size: 1518 bytes
Desc: not available
URL: <http://lists.racket-lang.org/dev/archive/attachments/20140414/bcb96c50/attachment-0001.obj>
-------------- next part --------------
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")
![[logo]](/logo.png){kind=logo}