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

improve the open-collection-path menu item

Browse Source 
specifically add support for using a racket other than
the one that drracket is currently using to find the
current-library-collection-paths and current-library-collection-links

also, split up the code in a better way and some bug fixes
This commit is contained in:
Robby Findler 2013-11-09 16:42:51 -06:00
parent 88e3d84d82
commit 9f30af820d
2 changed files with 224 additions and 214 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

432
pkgs/drracket-pkgs/drracket/drracket/private/get-module-path.rkt
View File

@ -1,224 +1,125 @@
#lang racket/base #lang racket/base
(require racket/class (require racket/class
racket/gui/base
string-constants)
(module find-completions racket/base
(require racket/contract/base)
(provide
(contract-out
[find-completions (-> string? (listof (list/c string? path?)))]))
(define (ignore? x) (member x '("compiled")))
(define (find-completions string)
(find-completions/internal string
(find-all-collection-dirs)
directory-list
directory-exists?))
(define (find-completions/internal string collection-dirs dir->content is-dir?)
(define segments (regexp-split #rx"/" string))
(define first-candidates
(cond
[(null? segments) '()]
[else
(define reg (regexp
(string-append "^"
(regexp-quote (car segments))
(if (null? (cdr segments))
""
"$"))))
(filter (λ (line) (regexp-match reg (list-ref line 0)))
collection-dirs)]))
(define unsorted
(let loop ([segments (cdr segments)]
[candidates first-candidates])
(cond
[(null? segments) candidates]
[else
(define reg (regexp (string-append
"^"
(regexp-quote (car segments))
(if (null? (cdr segments))
""
"$"))))
(define nexts
(for*/list ([key+candidate (in-list candidates)]
[candidate (in-value (list-ref key+candidate 1))]
#:when (is-dir? candidate)
[ent (in-list (dir->content candidate))]
[ent-str (in-value (path->string ent))]
#:unless (ignore? ent-str)
#:when (regexp-match reg ent-str))
(list ent-str (build-path candidate ent))))
(loop (cdr segments) nexts)])))
(sort unsorted string<=? #:key (λ (x) (path->string (list-ref x 1)))))
;; -> (listof (list string? path?))
;; returns a list of all of the directories that are being treated as collections,
;; (together with the names of the collections)
(define (find-all-collection-dirs)
;; link-content : (listof (list (or/c 'root 'static-root string?) path?))
(define link-content
(apply
append
(for/list ([link (in-list (current-library-collection-links))])
(cond
[link
(define-values (base name dir?) (split-path link))
(if (file-exists? link)
(for/list ([link-ent (call-with-input-file link read)]
#:when (if (= 3 (length link-ent))
(regexp-match (list-ref link-ent 2) (version))
#t))
`(,(list-ref link-ent 0)
,(simplify-path (build-path base (list-ref link-ent 1)))))
'())]
[else
(for/list ([clp (in-list (current-library-collection-paths))])
`(root ,(simplify-path clp)))]))))
(apply
append
(for/list ([just-one (in-list link-content)])
(define-values (what pth) (apply values just-one))
(cond
[(string? what)
(list just-one)]
[else
(cond
[(directory-exists? pth)
(for/list ([dir (in-list (directory-list pth))]
#:when (directory-exists? (build-path pth dir)))
(list (path->string dir) (build-path pth dir)))]
[else '()])]))))
(module+ test
(require rackunit
racket/list
racket/contract
racket/match)
(define/contract find-completions/c
(-> string? (listof (list/c string? path?)) (-> path? (listof path?)) (-> path? boolean?)
(listof (list/c string? path?)))
find-completions/internal)
(define coll-table
`(("racket" ,(string->path "/plt/pkgs/compatibility-pkgs/compatibility-lib/racket"))
("racket" ,(string->path "/plt/pkgs/draw-pkgs/draw-lib/racket"))
("racket" ,(string->path "/plt/racket/collects/racket"))
("rackunit" ,(string->path "plt/pkgs/gui-pkgs/gui-lib/rackunit"))))
(define (dir-list d)
(match (path->string d)
["/plt/racket/collects/racket"
(map string->path '("list.rkt" "info.rkt" "include.rkt" "init.rkt" "gui"))]
["/plt/racket/collects/racket/gui"
(map string->path '("dynamic.rkt"))]
["/plt/pkgs/draw-pkgs/draw-lib/racket"
(map string->path '("gui"))]
["/plt/pkgs/draw-pkgs/draw-lib/racket/gui"
(map string->path '("draw.rkt"))]
[_ '()]))
(define (dir-exists? d)
(not (regexp-match #rx"rkt$" (path->string d))))
(check-equal?
(find-completions/c "rack/" coll-table dir-list dir-exists?)
'())
(check-equal?
(find-completions/c "rack" coll-table dir-list dir-exists?)
coll-table)
(check-equal?
(find-completions/c "racku" coll-table dir-list dir-exists?)
(list (last coll-table)))
(check-equal?
(find-completions/c "racket/i" coll-table dir-list dir-exists?)
(list (list "include.rkt" (string->path "/plt/racket/collects/racket/include.rkt"))
(list "info.rkt" (string->path "/plt/racket/collects/racket/info.rkt"))
(list "init.rkt" (string->path "/plt/racket/collects/racket/init.rkt"))))
(check-equal?
(find-completions/c "racket/" coll-table dir-list dir-exists?)
(list (list "gui" (string->path "/plt/pkgs/draw-pkgs/draw-lib/racket/gui"))
(list "gui" (string->path "/plt/racket/collects/racket/gui"))
(list "include.rkt" (string->path "/plt/racket/collects/racket/include.rkt"))
(list "info.rkt" (string->path "/plt/racket/collects/racket/info.rkt"))
(list "init.rkt" (string->path "/plt/racket/collects/racket/init.rkt"))
(list "list.rkt" (string->path "/plt/racket/collects/racket/list.rkt"))))
(check-equal?
(find-completions/c "racket/g" coll-table dir-list dir-exists?)
(list (list "gui" (string->path "/plt/pkgs/draw-pkgs/draw-lib/racket/gui"))
(list "gui" (string->path "/plt/racket/collects/racket/gui"))))
(check-equal?
(find-completions/c "racket/gui/d" coll-table dir-list dir-exists?)
(list (list "draw.rkt" (string->path "/plt/pkgs/draw-pkgs/draw-lib/racket/gui/draw.rkt"))
(list "dynamic.rkt" (string->path "/plt/racket/collects/racket/gui/dynamic.rkt"))))))
(module+ test (require (submod ".." find-completions test)))
(require (submod "." find-completions)
racket/contract racket/contract
framework) racket/gui/base
string-constants
framework
"find-completions.rkt")
(provide (provide
(contract-out (contract-out
[get-module-path-from-user [get-module-path-from-user
(->* () (#:init string? #:pref symbol?) (or/c path? #f))])) (->* () (#:init string? #:pref symbol?) (or/c path? #f))]))
(define (get-module-path-from-user #:init [init-value ""] #:pref [pref-sym #f]) (define (get-module-path-from-user #:init [init-value ""]
#:pref [pref-sym #f])
(define dlg% (define dlg%
(class dialog% (class dialog%
(define/override (on-subwindow-char receiver event) (define/override (on-subwindow-char receiver event)
(cond (cond
[(member (send event get-key-code) '(up down)) [(member (send event get-key-code) '(up down))
(define old-sel (send lb get-selection)) (up/down-callback (send event get-key-code))]
(define dir (if (equal? (send event get-key-code) 'up)
-1
1))
(unless (= 0 (send lb get-number))
(send lb set-selection
(cond
[old-sel
(modulo (+ old-sel
(if (equal? (send event get-key-code) 'up)
-1
1))
(send lb get-number))]
[(equal? (send event get-key-code) 'up)
(- (send lb get-number) 1)]
[else
0])))]
[else (super on-subwindow-char receiver event)])) [else (super on-subwindow-char receiver event)]))
(define/public (new-clcl/clcp clcl/clcp)
(update-list-of-paths))
(super-new))) (super-new)))
(define dlg (new dlg% [label ""][width 600][height 600])) (define dlg (new dlg% [label ""][width 600][height 600]))
(define (tf-callback)
(adjust-lb)
(update-buttons))
(define tf (new text-field% [parent dlg] [label #f] (define tf (new text-field% [parent dlg] [label #f]
[init-value init-value] [init-value init-value]
[callback (λ (tf evt) [callback (λ (tf evt) (tf-callback))]))
(when pref-sym
(preferences:set pref-sym (send tf get-value)))
(tf-callback))]))
(define lb (new list-box% (define lb (new list-box%
[parent dlg] [choices '()] [label #f] [parent dlg] [choices '()] [label #f]
[callback (λ (lb evt) (update-buttons))])) [callback (λ (lb evt) (update-buttons))]))
(define different-racket-panel
(new vertical-panel%
[parent dlg]
[stretchable-height #f]
[alignment '(left center)]))
(define racket-path-cb
(new check-box%
[label (string-constant use-a-different-racket)]
[value (list-ref (preferences:get racket-binary-pref) 0)]
[callback (λ (_1 _2) (racket-path-cb-callback))]
[parent different-racket-panel]))
(define racket-path-tf
(new text-field%
[parent different-racket-panel]
[label (string-constant path-to-racket-binary)]
[init-value (list-ref (preferences:get racket-binary-pref) 1)]
[callback (λ (_1 _2) (racket-path-tf-callback))]))
(define bp (new horizontal-panel%
[parent dlg]
[stretchable-height #f]
[alignment '(right center)]))
(define enter-sub-button
(new button%
[parent bp]
[style '(border)]
[label (string-constant enter-subcollection)]
[callback (λ (_1 _2) (enter-sub))]))
(define-values (ok-button cancel-button)
(gui-utils:ok/cancel-buttons
bp
(λ (_1 _2) (ok))
(λ (_1 _2) (cancel))))
(define (tf-callback)
(when pref-sym
(preferences:set pref-sym (send tf get-value)))
(update-list-of-paths))
(define (up/down-callback key)
(define up? (equal? key 'up))
(define old-sel (send lb get-selection))
(define dir (if up? -1 1))
(unless (= 0 (send lb get-number))
(send lb set-selection
(cond
[old-sel
(modulo (+ old-sel dir)
(send lb get-number))]
[up?
(- (send lb get-number) 1)]
[else
0])))
(update-buttons))
(define (racket-path-tf-callback)
(preferences:set racket-binary-pref
(list (list-ref (preferences:get racket-binary-pref) 0)
(send racket-path-tf get-value)))
(update-list-of-paths)
(maybe-turn-racket-path-pink)
(new-alternate-racket (send racket-path-tf get-value) dlg))
(define (racket-path-cb-callback)
(define nv (send racket-path-cb get-value))
(preferences:set racket-binary-pref
(list nv (list-ref (preferences:get racket-binary-pref) 1)))
(update-different-racket-gui)
(update-list-of-paths)
(when nv
(send racket-path-tf focus)))
(define (update-list-of-paths)
(adjust-lb)
(update-buttons))
(define (adjust-lb) (define (adjust-lb)
(send lb clear) (send lb clear)
(unless (equal? (send tf get-value) "") (unless (equal? (send tf get-value) "")
(for ([i (in-list (find-completions (send tf get-value)))] (define alt-racket-info
(and (send racket-path-cb get-value)
(get-clcl/clcp)))
(for ([i (in-list (find-completions (send tf get-value)
#:alternate-racket alt-racket-info))]
[n (in-naturals)]) [n (in-naturals)])
(send lb append (path->string (list-ref i 1))) (send lb append (path->string (list-ref i 1)))
;; data holds a path => open the file ;; data holds a path => open the file
@ -231,18 +132,41 @@
(when (= 1 (send lb get-number)) (when (= 1 (send lb get-number))
(send lb set-selection 0)))) (send lb set-selection 0))))
(define bp (new horizontal-panel% (define (maybe-turn-racket-path-pink)
[parent dlg] (define pth (send racket-path-tf get-value))
[stretchable-height #f] (define bkg
[alignment '(right center)])) (cond
[(and (file-exists? pth)
(member 'execute (file-or-directory-permissions pth)))
"white"]
[else "yellow"]))
(send racket-path-tf set-field-background
(send the-color-database find-color bkg)))
(define (update-different-racket-gui)
(send different-racket-panel
change-children
(λ (l)
(if (list-ref (preferences:get racket-binary-pref) 0)
(list racket-path-cb racket-path-tf)
(list racket-path-cb)))))
(define (forward-new-alternate-racket)
(cond
[(send racket-path-cb get-value)
(define s (send racket-path-tf get-value))
(and (not (equal? s ""))
(not (regexp-match? #rx"\0" s))
s)]
[else #f]))
(define cancelled? #t) (define cancelled? #t)
(define (ok button evt) (define (ok)
(set! cancelled? #f) (set! cancelled? #f)
(send dlg show #f)) (send dlg show #f))
(define (cancel button evt) (send dlg show #f)) (define (cancel) (send dlg show #f))
(define (enter-sub button evt) (define (enter-sub)
(define item-to-act-on (get-item-to-act-on)) (define item-to-act-on (get-item-to-act-on))
(define mtch (regexp-match #rx"(^.*/)[^/]*$" (send tf get-value))) (define mtch (regexp-match #rx"(^.*/)[^/]*$" (send tf get-value)))
(define prefix (define prefix
@ -253,17 +177,8 @@
(send tf set-value (string-append prefix (send tf set-value (string-append prefix
(send lb get-data item-to-act-on) (send lb get-data item-to-act-on)
"/")) "/"))
(adjust-lb) (update-list-of-paths))
(update-buttons))
(define enter-sub-button (new button%
[parent bp]
[style '(border)]
[label (string-constant enter-subcollection)]
[callback enter-sub]))
(define-values (ok-button cancel-button) (gui-utils:ok/cancel-buttons bp ok cancel))
(define (update-buttons) (define (update-buttons)
(define item-to-act-on (get-item-to-act-on)) (define item-to-act-on (get-item-to-act-on))
(cond (cond
@ -285,9 +200,100 @@
(and (= 1 (send lb get-number)) (and (= 1 (send lb get-number))
0))) 0)))
(adjust-lb) (update-list-of-paths)
(update-buttons) (update-different-racket-gui)
(maybe-turn-racket-path-pink)
(send dlg show #t) (send dlg show #t)
(cond (cond
[cancelled? #f] [cancelled? #f]
[else (send lb get-data (get-item-to-act-on))])) [else (send lb get-data (get-item-to-act-on))]))
(define racket-binary-pref 'drracket:different-racket-for-open-collection-path)
(preferences:set-default racket-binary-pref (list #f "") (list/c boolean? string?))
;; the thread always holds the value of the clcp/clcf
;; for (list-ref (preferences:get racket-binary-pref) 1),
;; even if (list-ref (preferences:get racket-binary-pref) 0)
;; is #f (in which case, no one asks for the value inside the thread)
(define (new-alternate-racket str dlg)
(init-alternate-racket-thread)
(channel-put new-alternate-racket-chan (list str dlg)))
(define new-alternate-racket-chan (make-channel))
(define (get-clcl/clcp)
(init-alternate-racket-thread)
(channel-get current-alternate-racket-chan))
(define current-alternate-racket-chan (make-channel))
(define (init-alternate-racket-thread)
(unless thd
(define pref-val (preferences:get racket-binary-pref))
(set! thd
(thread (alternate-racket-thread-loop (list-ref pref-val 1))))))
(define thd #f)
(define (fire-off-alternate-racket-call str+dlg)
(define new-clcl-thread-pending-chan (make-channel))
(thread
(λ ()
(define-values (a b) (alternate-racket-clcl/clcp (list-ref str+dlg 0)))
(channel-put new-clcl-thread-pending-chan
(list (list a b)
(list-ref str+dlg 1)))))
new-clcl-thread-pending-chan)
(define (alternate-racket-thread-loop initial-alternate-racket)
(λ ()
(let loop ([clcl-thread-pending-chan #f]
;; (cons/c string? (is-a?/c dialog%))
[pending-str+dlg #f]
[clcl/clcp (if initial-alternate-racket
(let-values ([(a b) (alternate-racket-clcl/clcp
initial-alternate-racket)])
(list a b))
(list (current-library-collection-links)
(current-library-collection-paths)))])
(sync
(handle-evt
new-alternate-racket-chan
(λ (str+dlg)
(cond
[clcl-thread-pending-chan
(loop clcl-thread-pending-chan
str+dlg
clcl/clcp)]
[else
(define new-clcl-thread-pending-chan
(fire-off-alternate-racket-call str+dlg))
(loop new-clcl-thread-pending-chan
#f
clcl/clcp)])))
(handle-evt
(channel-put-evt current-alternate-racket-chan clcl/clcp)
(λ (c)
(loop clcl-thread-pending-chan
pending-str+dlg
clcl/clcp)))
(if clcl-thread-pending-chan
(handle-evt
clcl-thread-pending-chan
(λ (new-clcl/clcp+dlg)
(cond
[pending-str+dlg
(loop (fire-off-alternate-racket-call pending-str+dlg)
#f
clcl/clcp)]
[else
(define new-clcl/clcp (list-ref new-clcl/clcp+dlg 0))
(define dlg (list-ref new-clcl/clcp+dlg 1))
(parameterize ([current-eventspace (send dlg get-eventspace)])
(queue-callback
(λ ()
(send dlg new-clcl/clcp new-clcl/clcp))))
(loop #f
#f
new-clcl/clcp)])))
never-evt)))))

6
pkgs/drracket-pkgs/drracket/drracket/private/unit.rkt
View File

@ -3770,7 +3770,11 @@
[`(lib ,(? string? s)) [`(lib ,(? string? s))
(define m (regexp-match #rx"^(.*/)[^/]*$" s)) (define m (regexp-match #rx"^(.*/)[^/]*$" s))
(and m (and m
(list-ref m 1))]))) (list-ref m 1))]
[else #f])))
;; editing-module-path won't find anything interesting
;; if the get-module-path-from-user is using some other
;; racket binary
(define pth (define pth
(get-module-path-from-user (get-module-path-from-user
#:init (or editing-module-path #:init (or editing-module-path