improve the open-collection-path menu item
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
parent
88e3d84d82
commit
9f30af820d
|
|
@ -1,224 +1,125 @@
|
|||
#lang racket/base
|
||||
(require racket/class
|
||||
racket/contract
|
||||
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
|
||||
framework)
|
||||
string-constants
|
||||
framework
|
||||
"find-completions.rkt")
|
||||
|
||||
(provide
|
||||
(contract-out
|
||||
[get-module-path-from-user
|
||||
(->* () (#: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%
|
||||
(class dialog%
|
||||
(define/override (on-subwindow-char receiver event)
|
||||
(cond
|
||||
[(member (send event get-key-code) '(up down))
|
||||
(define old-sel (send lb get-selection))
|
||||
(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])))]
|
||||
(up/down-callback (send event get-key-code))]
|
||||
[else (super on-subwindow-char receiver event)]))
|
||||
(define/public (new-clcl/clcp clcl/clcp)
|
||||
(update-list-of-paths))
|
||||
(super-new)))
|
||||
|
||||
(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]
|
||||
[init-value init-value]
|
||||
[callback (λ (tf evt)
|
||||
(when pref-sym
|
||||
(preferences:set pref-sym (send tf get-value)))
|
||||
(tf-callback))]))
|
||||
[callback (λ (tf evt) (tf-callback))]))
|
||||
(define lb (new list-box%
|
||||
[parent dlg] [choices '()] [label #f]
|
||||
[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)
|
||||
(send lb clear)
|
||||
(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)])
|
||||
(send lb append (path->string (list-ref i 1)))
|
||||
;; data holds a path => open the file
|
||||
|
|
@ -231,18 +132,41 @@
|
|||
(when (= 1 (send lb get-number))
|
||||
(send lb set-selection 0))))
|
||||
|
||||
(define bp (new horizontal-panel%
|
||||
[parent dlg]
|
||||
[stretchable-height #f]
|
||||
[alignment '(right center)]))
|
||||
(define (maybe-turn-racket-path-pink)
|
||||
(define pth (send racket-path-tf get-value))
|
||||
(define bkg
|
||||
(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 (ok button evt)
|
||||
(define (ok)
|
||||
(set! cancelled? #f)
|
||||
(send dlg show #f))
|
||||
(define (cancel button evt) (send dlg show #f))
|
||||
(define (enter-sub button evt)
|
||||
(define (cancel) (send dlg show #f))
|
||||
(define (enter-sub)
|
||||
(define item-to-act-on (get-item-to-act-on))
|
||||
(define mtch (regexp-match #rx"(^.*/)[^/]*$" (send tf get-value)))
|
||||
(define prefix
|
||||
|
|
@ -253,16 +177,7 @@
|
|||
(send tf set-value (string-append prefix
|
||||
(send lb get-data item-to-act-on)
|
||||
"/"))
|
||||
(adjust-lb)
|
||||
(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))
|
||||
(update-list-of-paths))
|
||||
|
||||
(define (update-buttons)
|
||||
(define item-to-act-on (get-item-to-act-on))
|
||||
|
|
@ -285,9 +200,100 @@
|
|||
(and (= 1 (send lb get-number))
|
||||
0)))
|
||||
|
||||
(adjust-lb)
|
||||
(update-buttons)
|
||||
(update-list-of-paths)
|
||||
(update-different-racket-gui)
|
||||
(maybe-turn-racket-path-pink)
|
||||
(send dlg show #t)
|
||||
(cond
|
||||
[cancelled? #f]
|
||||
[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)))))
|
||||
|
|
|
|||
|
|
@ -3770,7 +3770,11 @@
|
|||
[`(lib ,(? string? s))
|
||||
(define m (regexp-match #rx"^(.*/)[^/]*$" s))
|
||||
(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
|
||||
(get-module-path-from-user
|
||||
#:init (or editing-module-path
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user