From 9f30af820db1886a986f1d71ec1dfd023dc4efc0 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Sat, 9 Nov 2013 16:42:51 -0600
Subject: [PATCH] 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
---
 .../drracket/private/get-module-path.rkt      | 432 +++++++++---------
 .../drracket/drracket/private/unit.rkt        |   6 +-
 2 files changed, 224 insertions(+), 214 deletions(-)

diff --git a/pkgs/drracket-pkgs/drracket/drracket/private/get-module-path.rkt b/pkgs/drracket-pkgs/drracket/drracket/private/get-module-path.rkt
index ecd96308a7..e83e832fd5 100644
--- a/pkgs/drracket-pkgs/drracket/drracket/private/get-module-path.rkt
+++ b/pkgs/drracket-pkgs/drracket/drracket/private/get-module-path.rkt
@@ -1,224 +1,125 @@
 #lang racket/base
-(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)
+(require racket/class
          racket/contract
-         framework)
+         racket/gui/base
+         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,17 +177,8 @@
     (send tf set-value (string-append prefix
                                       (send lb get-data item-to-act-on)
                                       "/"))
-    (adjust-lb)
-    (update-buttons))
+    (update-list-of-paths))
     
-  (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 item-to-act-on (get-item-to-act-on))
     (cond
@@ -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)))))
diff --git a/pkgs/drracket-pkgs/drracket/drracket/private/unit.rkt b/pkgs/drracket-pkgs/drracket/drracket/private/unit.rkt
index 790b819e5d..3b83eb57bc 100644
--- a/pkgs/drracket-pkgs/drracket/drracket/private/unit.rkt
+++ b/pkgs/drracket-pkgs/drracket/drracket/private/unit.rkt
@@ -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