raco setup: put launchers for user collections in user space

Also, remove executables (in full setup or "tidy" mode) when the
corresponding collections are removed.

As a result of these changes, `raco pkg' puts launchers from user-scoped
packages in user space and cleans up launchers from removed packages.

There's no attempt to include "launchers.rktd" in a distribution.
That should be ok: having an entry in "launchers.rktd" just
makes a launcher a candidate for removal. Including "launchers.rktd"
would be a hassle for many reasons, including that the initial set
of launchers is platform-specific.

collects/launcher/launcher-unit.rkt

@@ -622,15 +622,19 @@
      (string-append (if mred? file (unix-sfx file mred?)) ".exe")]
     [else file]))
 
-(define (program-launcher-path name mred?)
+(define (program-launcher-path name mred? user?)
   (let* ([variant (current-launcher-variant)]
          [mac-script? (and (eq? (system-type) 'macosx)
                            (script-variant? variant))])
     (let ([p (add-file-suffix
               (build-path
                (if (or mac-script? (not mred?))
-                   (find-console-bin-dir)
+                   (if user?
-                   (find-gui-bin-dir))
+                       (find-user-console-bin-dir)
+                       (find-console-bin-dir))
+                   (if user?
+                       (find-user-gui-bin-dir)
+                       (find-gui-bin-dir)))
                ((if mac-script? unix-sfx sfx) name mred?))
               variant
               mred?)])
@@ -639,20 +643,23 @@
           (path-replace-suffix p #".app")
           p))))
 
-(define (gracket-program-launcher-path name)
+(define (gracket-program-launcher-path name #:user? [user? #f])
-  (program-launcher-path name #t))
+  (program-launcher-path name #t user?))
-(define (mred-program-launcher-path name)
+(define (mred-program-launcher-path name #:user? [user? #f])
-  (gracket-program-launcher-path name))
+  (gracket-program-launcher-path name #:user? user?))
 
-(define (racket-program-launcher-path name)
+(define (racket-program-launcher-path name #:user? [user? #f])
   (case (system-type)
     [(macosx)
-     (add-file-suffix (build-path (find-console-bin-dir) (unix-sfx name #f))
+     (add-file-suffix (build-path (if user?
+                                      (find-user-console-bin-dir)
+                                      (find-console-bin-dir))
+                                  (unix-sfx name #f))
                       (current-launcher-variant)
                       #f)]
-    [else (program-launcher-path name #f)]))
+    [else (program-launcher-path name #f user?)]))
-(define (mzscheme-program-launcher-path name)
+(define (mzscheme-program-launcher-path name #:user? [user? #f])
-  (racket-program-launcher-path name))
+  (racket-program-launcher-path name #:user? user?))
 
 (define (gracket-launcher-is-directory?)
   #f)

collects/scribblings/raco/launcher.scrbl

@@ -175,10 +175,14 @@ arguments.}
 
 @section{Launcher Path and Platform Conventions}
 
-@defproc[(gracket-program-launcher-path [name string?]) path?]{
+@defproc[(gracket-program-launcher-path [name string?]
+                                        [#:user? user? any/c #f]) 
+         path?]{
 
-Returns a pathname for an executable in the Racket installation
+Returns a pathname for an executable called something like @racket[name]
-called something like @racket[name].  For Windows, the @filepath{.exe}
+in the Racket installation (if @racket[user?] is @racket[#f]) or the
+user's Racket executable directory (if @racket[user?] is @racket[#t]).
+For Windows, the @filepath{.exe}
 suffix is automatically appended to @racket[name]. For Unix,
 @racket[name] is changed to lowercase, whitespace is changed to
 @litchar{-}, and the path includes the @filepath{bin} subdirectory of
@@ -186,9 +190,11 @@ the Racket installation. For Mac OS X, the @filepath{.app} suffix
 is appended to @racket[name].}
 
 
-@defproc[(racket-program-launcher-path [name string?]) path?]{
+@defproc[(racket-program-launcher-path [name string?]
+                                       [#:user? user? any/c #f])
+         path?]{
 
-Returns the same path as @racket[(gracket-program-launcher-path name)]
+Returns the same path as @racket[(gracket-program-launcher-path name #:user? user?)]
 for Unix and Windows. For Mac OS X, the result is the same as for
 Unix.}
 
@@ -254,7 +260,7 @@ Like @racket[gracket-launcher-get-file-extension+style+filters], but for
 Racket launchers.}
 
 @deftogether[(
-@defproc[(mred-program-launcher-path [name string?]) path?]
+@defproc[(mred-program-launcher-path [name string?] [#:user? user? any/c #f]) path?]
 @defproc[(mred-launcher-is-directory?) boolean?]
 @defproc[(mred-launcher-is-actually-directory?) boolean?]
 @defproc[(mred-launcher-add-suffix [path-string? path]) path?]
@@ -268,7 +274,7 @@ Backward-compatible aliases for
 @racket[gracket-program-launcher-path], etc.}
 
 @deftogether[(
-@defproc[(mzscheme-program-launcher-path [name string?]) path?]
+@defproc[(mzscheme-program-launcher-path [name string?] [#:user? user? any/c #f]) path?]
 @defproc[(mzscheme-launcher-is-directory?) boolean?]
 @defproc[(mzscheme-launcher-is-actually-directory?) boolean?]
 @defproc[(mzscheme-launcher-add-suffix [path-string? path]) path?]

collects/scribblings/raco/setup.scrbl

@@ -961,6 +961,15 @@ Imports @racket[mred^] and exports @racket[setup:plt-installer^]. }
   stand-alone GRacket executable resides. The result is @racket[#f] if no such
   directory is available.}
 
+@defproc[(find-user-console-bin-dir) path?]{
+  Returns a path to the user's executable directory; the directory
+  indicated by the returned path may or may not exist.}
+
+@defproc[(find-user-gui-bin-dir) path?]{
+  Returns a path to the user's executable directory for graphical
+  programs; the directory indicated by the returned path may or may
+  not exist.}
+
 @defthing[absolute-installation? boolean?]{
   A binary boolean flag that is true if this installation is using
   absolute path names.}

collects/setup/setup-unit.rkt

@@ -1073,6 +1073,18 @@
       (unless (list-of (list-of string?) l)
         (error "result is not a list of strings:" l)))
     (define ((or-f f) x) (when x (f x)))
+    (when (or no-specific-collections?
+              (make-tidy))
+      (unless (avoid-main-installation)
+        (tidy-launchers #f
+                        (find-console-bin-dir)
+                        (find-gui-bin-dir)
+                        (find-lib-dir)))
+      (when (make-user)
+        (tidy-launchers #t
+                        (find-user-console-bin-dir)
+                        (find-user-gui-bin-dir)
+                        (find-user-lib-dir))))
     (for ([cc ccs-to-compile])
       (begin-record-error cc "Launcher Setup"
         (define info (cc-info cc))
@@ -1102,7 +1114,19 @@
              (for ([mzln (in-list mzlns)]
                    [mzll (in-list (or mzlls (map (lambda (_) #f) mzlns)))]
                    [mzlf (in-list (or mzlfs (map (lambda (_) #f) mzlns)))])
-               (define p (program-launcher-path mzln))
+               (define p (program-launcher-path mzln #:user? (not (cc-main? cc))))
+               (define receipt-path
+                 (build-path (if (cc-main? cc)
+                                 (find-lib-dir)
+                                 (find-user-lib-dir))
+                             "launchers.rktd"))
+               (define (prep-dir p)
+                 (define dir (path-only p))
+                 (make-directory* dir))
+               (prep-dir p)
+               (prep-dir receipt-path)
+               (record-launcher receipt-path mzln kind (current-launcher-variant) 
+                                (cc-collection cc) (cc-path cc))
                (define aux
                  `((exe-name . ,mzln)
                    (framework-root . #f)
@@ -1174,6 +1198,90 @@
                            make-mzscheme-launcher
                            mzscheme-launcher-up-to-date?))))))
 
+  (define (read-launchers receipt-path)
+    (if (file-exists? receipt-path)
+        (with-handlers ([exn:fail?
+                         (lambda (exn)
+                           (setup-printf
+                            "WARNING"
+                            "error reading launcher list ~s: ~a"
+                            receipt-path
+                            (exn-message exn))
+                           #hash())])
+          (call-with-input-file* 
+           receipt-path 
+           (lambda (i)
+             (define ht (read i))
+             (if (hash? ht)
+                 ht
+                 (error "content is not a hash table")))))
+        #hash()))
+
+  (define (write-launchers receipt-path ht)
+    (call-with-output-file*
+     #:exists 'truncate/replace
+     receipt-path
+     (lambda (o) (write ht o))))
+
+  (define (record-launcher receipt-path name kind variant coll coll-path)
+    (let ([ht (read-launchers receipt-path)])
+      (define coll-rel (let ([p (path->main-collects-relative coll-path)])
+                         (if (path? p)
+                             (path->bytes p)
+                             p)))
+      (define exe-key (vector kind
+                              variant
+                              name))
+      (define exe-val (cons (map path->string coll) coll-rel))
+      (unless (equal? (hash-ref ht exe-key #f)
+                      exe-val)
+        (let ([ht (hash-set ht exe-key exe-val)]) 
+          (write-launchers receipt-path ht)))))
+
+  (define (tidy-launchers user? bin-dir gui-bin-dir lib-dir)
+    (define receipt-path (build-path lib-dir "launchers.rktd"))
+    (define ht (read-launchers receipt-path))
+    (define ht2 (for/fold ([ht (hash)]) ([(k v) (in-hash ht)])
+                  (define coll-path (main-collects-relative->path (cdr v)))
+                  (cond
+                   [(and (directory-exists? coll-path)
+                         ;; Collection path must match collection resolution:
+                         (with-handlers ([exn:fail? (lambda (exn) #f)])
+                           (equal? coll-path (apply collection-path (car v)))))
+                    ;; keep the launcher
+                    (hash-set ht k v)]
+                   [else
+                    ;; remove the launcher
+                    (define kind (vector-ref k 0))
+                    (define variant (vector-ref k 1))
+                    (define name (vector-ref k 2))
+                    (parameterize ([current-launcher-variant variant])
+                      (define exe-path ((if (eq? kind 'gui)
+                                            gracket-program-launcher-path
+                                            racket-program-launcher-path)
+                                        name
+                                        #:user? user?))
+                      (define is-dir?
+                        (if (eq? kind 'gui)
+                            (gracket-launcher-is-actually-directory?)
+                            (racket-launcher-is-actually-directory?)))
+                      (define rel-exe-path
+                        ((if (eq? kind 'gui)
+                             path->relative-string/gui-bin 
+                             path->relative-string/console-bin)
+                         exe-path))
+                      (cond
+                       [(and (not is-dir?) (file-exists? exe-path))
+                        (setup-printf "deleting" "launcher ~a" rel-exe-path)
+                        (delete-file exe-path)]
+                       [(and is-dir? (directory-exists? exe-path))
+                        (setup-printf "deleting" "launcher ~a" rel-exe-path)
+                        (delete-directory/files exe-path)]))
+                    ht])))
+    (unless (equal? ht ht2)
+      (setup-printf "updating" "launcher list")
+      (write-launchers receipt-path ht2)))
+
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;; setup-unit Body                ;;
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;