fix `raco setup' for splicing collections

Closes PR 12676

collects/compiler/find-exe.rkt

@@ -3,9 +3,7 @@
          setup/variant)
 (provide find-exe)
 
-;; Find executable relative to the "mzlib"
+(define (find-exe [mred? #f] [variant (system-type 'gc)])
-;; collection.
-(define (find-exe mred? [variant (system-type 'gc)])
   (let* ([base (if mred?
                    (find-gui-bin-dir)
                    (find-console-bin-dir))]

collects/scribblings/raco/exe-api.scrbl

@@ -14,7 +14,8 @@
                      compiler/embed-sig
                      compiler/embed-unit
                      racket/runtime-path
-                     launcher/launcher))
+                     launcher/launcher
+                     compiler/find-exe))
 
 @title{API for Creating Executables}
 
@@ -450,14 +451,13 @@ Includes the identifiers provided by @racketmodname[compiler/embed].}
 
 A unit that imports nothing and exports @racket[compiler:embed^].}
 
-@section{Finding the name of the executable}
+@section{Finding the Racket Executable}
 
 @defmodule[compiler/find-exe]
 
-@defproc[(find-exe [gracket? boolean?]
+@defproc[(find-exe [gracket? any/c #f]
                    [variant (or/c 'cgc '3m) (system-type 'gc)])
          path?]{
 
-  Finds the path to the racket (or gracket) executable.
+  Finds the path to the @exec{racket} or @exec{gracket} (when
-}
+  @racket[gracket?] is true) executable.}
-               

collects/scribblings/raco/link.scrbl

@@ -2,7 +2,8 @@
 @(require scribble/manual
           scribble/bnf 
           "common.rkt"
-          (for-label racket/base))
+          (for-label racket/base
+                     racket/contract))
 
 @title[#:tag "link"]{@exec{raco link}: Library Collection Links}
 
@@ -111,7 +112,7 @@ Full command-line options:
 @defmodule[setup/link]
 
 @defproc[(links [dir path?] ...
-                [#:user? user? #t]
+                [#:user? user? any/c #t]
                 [#:file file (or/c path-string? #f) #f]
                 [#:name name (or/c string? #f) #f]
                 [#:root? root? any/c #f]
@@ -119,7 +120,8 @@ Full command-line options:
                 [#:error error-proc (symbol? string? any/c ... . -> . any) error]
                 [#:remove? remove? any/c #f]
                 [#:show? show? any/c #f]
-                [#:repair? repair? any/c #f])
+                [#:repair? repair? any/c #f]
+                [#:with-path? with-path? any/c #f])
           list?]{
 
 A function version of the @exec{raco link} command that always works
@@ -132,9 +134,11 @@ The @racket[error-proc] argument is called to raise exceptions that
 would be fatal to the @exec{raco link} command.
 
 If @racket[remove?] is true, the result is a list of entries that were
-removed from the file.  If @racket[remove?] is false but
+removed from the file.  If @racket[remove?] is @racket[#f] but
 @racket[root?] is true, the result is a list of paths for collection
-roots. If @racket[remove?] and @racket[root?] are both false, the
+roots. If @racket[remove?] and @racket[root?] are both @racket[#f],
-result is a list of top-level collection names (as strings) that are
+the result is a list for top-level collections that are mapped by
-mapped by @racket[file] and that apply to the running version of
+@racket[file] and that apply to the running version of Racket; the
-Racket.}
+list is a list of strings for collection names if @racket[with-path?]
+is @racket[#f], or it is a list of pairs of collection-name strings
+and complete paths if @racket[with-path?] is true.}

collects/setup/link.rkt

@@ -14,6 +14,7 @@
                #:remove? [remove? #f]
                #:show? [show? #f]
                #:repair? [repair? #f]
+               #:with-path? [with-path? #f]
                . dirs)
   (define (check-name name)
     (unless (and (regexp-match #rx"^[a-zA-z0-9+_%-]+$" name)
@@ -203,6 +204,9 @@
               (when (and (string? (car e))
                          (or (null? (cddr e))
                              (regexp-match? (caddr e) (version))))
-                (hash-set! ht (car e) #t)))
+                (hash-set! ht (car e) (cadr e))))
-            (hash-map ht (lambda (k e) k))))))
+            (hash-map ht (lambda (k p) 
+                           (if with-path?
+                               (cons k (simplify p))
+                               k)))))))
 

collects/setup/setup-unit.rkt

@@ -203,15 +203,16 @@
     (setup-printf "WARNING" "~a" (exn->string exn))
     v)
 
-  ;; collection->cc : listof path -> cc/#f
+  ;; Maps a colletion name to a list of `cc's:
-  (define collection->cc-table (make-hash))
+  (define collection-ccs-table (make-hash))
-  (define (collection->cc collection-p 
+
+  ;; collection-cc! : listof-path .... -> cc
+  (define (collection-cc! collection-p 
+                          #:path [dir (apply collection-path collection-p)]
                           #:omit-root [omit-root #f]
                           #:info-root [given-info-root #f]
                           #:info-path [info-path #f]
                           #:info-path-mode [info-path-mode 'relative])
-    (hash-ref! collection->cc-table collection-p
-      (lambda ()
     (define info-root
       (or given-info-root
           (ormap (lambda (p)
@@ -222,10 +223,15 @@
                             (apply collection-path collection-p))
                           p)))
                  (current-library-collection-paths))))
-        (let ([dir (apply collection-path collection-p)])
     (unless (directory-exists? dir)
-            (error name-sym "directory does not exist for collection: ~s"
+      (error name-sym "directory: ~e does not exist for collection: ~s"
+             dir
              (string-join (map path->string collection-p) "/")))
+    (unless info-root
+      (error name-sym "cannot find info root for collection: ~s and path: ~e"
+             (string-join (map path->string collection-p) "/")
+             dir))
+    (define new-cc
       (make-cc* collection-p
                 dir
                 (if (eq? omit-root 'dir)
@@ -237,7 +243,17 @@
                 info-path-mode
                 ;; by convention, all collections have "version" 1 0. This
                 ;; forces them to conflict with each other.
-                    (list (cons 'lib (map path->string collection-p)) 1 0))))))
+                (list (cons 'lib (map path->string collection-p)) 1 0)))
+    (when new-cc
+      (hash-update! collection-ccs-table 
+                    collection-p 
+                    (lambda (lst) (cons new-cc lst))
+                    null))
+    new-cc)
+
+  ;; collection->ccs : listof-path -> listof-cc
+  (define (collection->ccs collection-p)
+    (hash-ref collection-ccs-table collection-p null))
 
   ;; planet-spec->planet-list : (list string string nat nat) -> (list path string string (listof string) nat nat) | #f
   ;; converts a planet package spec into the information needed to create a cc structure
@@ -257,9 +273,9 @@
                     owner pkg-name maj min))))]
       [_ spec]))
 
-  (define (planet->cc path #:omit-root [omit-root path] owner pkg-file extra-path maj min)
+  (define (planet-cc! path #:omit-root [omit-root path] owner pkg-file extra-path maj min)
     (unless (path? path)
-      (error 'planet->cc "non-path when building package ~e" pkg-file))
+      (error 'planet-cc! "non-path when building package ~e" pkg-file))
     (and (directory-exists? path)
          (make-cc* #f
                    path
@@ -275,7 +291,7 @@
   (define (planet-cc->sub-cc cc subdir)
     (match-let ([(list (list 'planet owner pkg-file extra-path ...) maj min)
                  (cc-shadowing-policy cc)])
-      (planet->cc (apply build-path (cc-path cc) (map bytes->path subdir))
+      (planet-cc! (apply build-path (cc-path cc) (map bytes->path subdir))
                   #:omit-root (cc-omit-root cc)
                   owner
                   pkg-file
@@ -283,46 +299,51 @@
                   maj
                   min)))
 
-  (define all-collections
+  ;; Add in all non-planet collections:
-    (let ([ht (make-hash)])
-      (define (maybe collection ->cc)
-        (hash-ref ht collection
-                  (lambda ()
-                    (let ([cc (->cc collection)])
-                      (when cc (hash-set! ht collection cc))))))
   (for ([cp (current-library-collection-paths)]
         #:when (directory-exists? cp)
         [collection (directory-list cp)]
         #:when (directory-exists? (build-path cp collection)))
-        (maybe (list collection) collection->cc))
+    (collection-cc! (list collection)
+                    #:path (build-path cp collection)))
   (let ([main-collects (find-collects-dir)])
-        (define (->cc col)
+    (define (cc! col #:path path)
-          (collection->cc col
+      (collection-cc! col
+                      #:path path
                       #:info-root main-collects
                       #:info-path-mode 'abs-in-relative
                       #:omit-root 'dir))
-        (for ([c (in-list (links #:user? #f))])
+    (for ([c+p (in-list (links #:user? #f #:with-path? #t))])
-          (maybe (list (string->path c)) ->cc))
+      (cc! (list (string->path (car c+p)))
+           #:path (cdr c+p)))
     (for ([cp (in-list (links #:root? #t #:user? #f))]
           #:when (directory-exists? cp)
           [collection (directory-list cp)]
           #:when (directory-exists? (build-path cp collection)))
-          (maybe (list collection) ->cc)))
+      (cc! (list collection)
+           #:path (build-path cp collection))))
   (when (make-user)
     (let ([user-collects (find-user-collects-dir)])
-          (define (->cc col)
+      (define (cc! col #:path path)
-            (collection->cc col
+        (unless user-collects
+          (error name-sym "cannot setup linked collection without a user-collection root"))
+        (collection-cc! col
+                        #:path path
                         #:info-root user-collects
                         #:info-path-mode 'abs-in-relative
                         #:omit-root 'dir))
-          (for ([c (in-list (links))])
+      (for ([c+p (in-list (links #:with-path? #t))])
-            (maybe (list (string->path c)) ->cc))
+        (cc! (list (string->path (car c+p)))
+             #:path (cdr c+p)))
       (for ([cp (in-list (links #:root? #t))]
             #:when (directory-exists? cp)
             [collection (directory-list cp)]
             #:when (directory-exists? (build-path cp collection)))
-            (maybe (list collection) ->cc))))
+        (cc! (list collection)
-      (hash-map ht (lambda (k v) v))))
+             #:path (build-path cp collection)))))
+
+  ;; `all-collections' lists all top-level collections (not from Planet):
+  (define all-collections (apply append (hash-map collection-ccs-table (lambda (k v) v))))
   
   ;; Close over sub-collections
   (define (collection-closure collections-to-compile make-subs)
@@ -363,7 +384,7 @@
       
     (define (build-collection-tree cc)
       (define (make-child-cc parent-cc name) 
-        (collection->cc (append (cc-collection parent-cc) (list name))
+        (collection-cc! (append (cc-collection parent-cc) (list name))
                         #:info-root (cc-info-root cc)
                         #:info-path (cc-info-path cc)
                         #:info-path-mode (cc-info-path-mode cc)
@@ -395,12 +416,11 @@
               (list cc srcs children-ccs)))))
     (map build-collection-tree collections-to-compile))
   
-
-    
   (define (plt-collection-closure collections-to-compile)
     (define (make-children-ccs cc children)
       (map (lambda (child)
-           (collection->cc (append (cc-collection cc) (list child))
+             (collection-cc! (append (cc-collection cc) (list child))
+                             #:path (build-path (cc-path cc) child)
                              #:info-root (cc-info-root cc)
                              #:info-path (cc-info-path cc)
                              #:info-path-mode (cc-info-path-mode cc)
@@ -408,13 +428,24 @@
            children))
     (collection-closure collections-to-compile make-children-ccs))
 
-  (define (check-again-all given-ccs)
+  (define (lookup-collection-closure collections-to-compile)
+    (define (lookup-children-ccs cc children)
+      (apply
+       append
+       (map (lambda (child)
+              (collection->ccs (append (cc-collection cc) (list child))))
+            children)))
+    (collection-closure collections-to-compile lookup-children-ccs))
+
+  (define all-collections-closure (plt-collection-closure all-collections))
+
+  (define (check-against-all given-ccs)
     (define (cc->name cc)
       (string-join (map path->string (cc-collection cc)) "/"))
     (define (cc->cc+name+id cc)
       (list cc (cc->name cc) (file-or-directory-identity (cc-path cc))))
     (define all-ccs+names+ids
-      (map cc->cc+name+id (plt-collection-closure all-collections)))
+      (map cc->cc+name+id all-collections-closure))
     ;; given collections
     (define given-ccs+names+ids (map cc->cc+name+id given-ccs))
     ;; descendants of given collections
@@ -422,7 +453,7 @@
       (remove-duplicates
        (append-map
         (lambda (cc)
-          (map cc->name (remq cc (plt-collection-closure (list cc)))))
+          (map cc->name (remq cc (lookup-collection-closure (list cc)))))
         given-ccs)))
     ;; given collections without duplicates and without ones that are already
     ;; descendants
@@ -431,7 +462,8 @@
        (filter (lambda (cc+name+id)
                  (not (member (cadr cc+name+id) descendants-names)))
                given-ccs+names+ids)
-       (lambda (x y) (equal? (cadr x) (cadr y)))))
+       (lambda (x y) (and (equal? (cadr x) (cadr y))
+                          (equal? (cc-path (car x)) (cc-path (car y)))))))
     ;; check that there are no bad duplicates in the given list
     (for ([given-cc+name+id (in-list given*-ccs+names+ids)])
       (cond
@@ -455,18 +487,32 @@
   (define top-level-plt-collects
     (if no-specific-collections?
       all-collections
-      (check-again-all
+      (check-against-all
-       (filter-map
+       (apply
+        append
+        (map
          (lambda (c)
-          (collection->cc (append-map (lambda (s)
+           (define elems (append-map (lambda (s) 
                                        (map string->path
                                             (regexp-split #rx"/" s)))
-                                      c)))
+                                     c))
-        x-specific-collections))))
+           (define ccs
+             (collection->ccs elems))
+           (when (null? ccs)
+             ;; let `collection-path' complain about the name, if that's the problem:
+             (apply collection-path elems)
+             ;; otherwise, it must be an issue with different ways to
+             ;; spell the name
+             (error name-sym
+                    (error name-sym
+                     "given collection path: \"~a\" is not in canonical form (e.g., wrong case on a case-insensitive filesystem)"
+                     (string-join c "/"))))
+           ccs)
+         x-specific-collections)))))
 
   (define planet-collects
     (if (make-planet)
-      (filter-map (lambda (spec) (apply planet->cc spec))
+      (filter-map (lambda (spec) (apply planet-cc! spec))
                   (if no-specific-collections?
                     (get-all-planet-packages)
                     (filter-map planet-spec->planet-list
@@ -482,7 +528,7 @@
 
   (define ccs-to-compile 
     (append
-      (sort-collections (plt-collection-closure top-level-plt-collects))
+      (sort-collections (lookup-collection-closure top-level-plt-collects))
       planet-dirs-to-compile))
 
 
@@ -761,7 +807,8 @@
     (setup-printf #f "--- compiling collections ---")
     (match (parallel-workers)
       [(? (lambda (x) (x . > . 1)))
-        (compile-cc (collection->cc (list (string->path "racket"))) 0)
+        (for/fold ([gcs 0]) ([cc (in-list (collection->ccs (list (string->path "racket"))))])
+          (compile-cc cc 0))
         (managed-compile-zo (collection-file-path "parallel-build-worker.rkt" "setup"))
         (with-specified-mode
          (lambda ()

collects/tests/racket/link.rkt

@@ -0,0 +1,243 @@
+#lang racket
+(require setup/link
+         compiler/find-exe)
+
+(define-syntax-rule (test expect expr)
+  (do-test expect expr 'expr))
+
+(define (do-test expect val expr)
+  (unless (equal? expect val)
+    (eprintf "test failed: ~.s; expected: ~e; actual: ~e\n" 
+             expr expect val)))
+
+;; ----------------------------------------
+;; set up
+
+(define work-dir (build-path (find-system-path 'temp-dir) "link-test"))
+(when (directory-exists? work-dir)
+  (delete-directory/files work-dir))
+(make-directory work-dir)
+
+(define link-file (build-path work-dir "links"))
+
+;; ----------------------------------------
+;; running Racket
+
+(define racket-exe (find-exe #f))
+
+(define (run-racket args)
+  (let ([o (open-output-string)]
+        [eo (open-output-string)])
+    (with-handlers ([exn? (lambda (exn) (raise exn))])
+      (parameterize ([current-output-port o]
+                     [current-error-port eo])
+        (apply system* 
+               racket-exe
+               (list* "-C"
+                      link-file
+                      args))))
+    (values (get-output-string o)
+            (get-output-string eo))))
+
+(define (test-racket result-str args)
+  (define-values (out err) (run-racket args))
+  (unless (string=? "" err)
+    (eprintf "test stderr: ~e\n" err))
+  (let ([eo (open-output-string)])
+    (display result-str eo)
+    (newline eo)
+    (do-test (get-output-string eo)
+             out
+             `(racket ,result-str ',args))))
+
+(define (run-setup collection 
+                   #:err [err-rx #f] 
+                   #:no-docs? [no-docs? #f])
+  (printf "setup ~s\n" collection)
+  (define-values (out err)
+    (run-racket (append `("-l-" "setup")
+                        (if no-docs?
+                            `("-D")
+                            null)
+                        `("-l" ,collection))))
+  (cond
+   [err-rx
+    (unless (regexp-match err-rx err)
+      (eprintf "setup non-matching stderr: ~e\n" err))]
+   [else
+    (unless (string=? "" err)
+      (eprintf "setup stderr: ~e\n" err))]))
+
+;; ----------------------------------------
+;; check setup errs
+
+(run-setup "Racket"
+           #:err "collection not found|not in canonical form")
+
+;; ----------------------------------------
+;; simple collection link
+
+(test null (links #:file link-file))
+(test null (links #:file link-file #:root? #t))
+
+(define c1-dir (build-path work-dir "c1"))
+(make-directory c1-dir)
+(test '("c1") (links c1-dir #:file link-file))
+
+(test '("c1") (links #:file link-file))
+(test (list (cons "c1" c1-dir)) (links #:with-path? #t #:file link-file))
+(test null (links #:file link-file #:root? #t))
+
+(with-output-to-file (build-path c1-dir "m1.rkt")
+  (lambda ()
+    (printf "#lang racket/base\n'm1\n")))
+
+(test-racket "'m1" '("-l" "c1/m1"))
+
+(run-setup "c1")
+(test #t (file-exists? (build-path c1-dir "compiled" "m1_rkt.zo")))
+
+;; ----------------------------------------
+;; splicing with "mzlib"
+
+(define mzlib-dir (build-path work-dir "mzlib"))
+(make-directory mzlib-dir)
+(test '("c1" "mzlib") (links mzlib-dir #:file link-file))
+
+(test '("c1" "mzlib") (links #:file link-file))
+(test null (links #:file link-file #:root? #t))
+
+(with-output-to-file (build-path mzlib-dir "m1.rkt")
+  (lambda ()
+    (printf "#lang racket/base\n'mz1\n")))
+
+(test-racket "'mz1" '("-l" "mzlib/m1"))
+
+(test-racket "#<channel>" '("-l" "racket/base" "-l" "mzlib/cml" "-e" "(channel)"))
+
+(run-setup "mzlib" #:no-docs? #t)
+(test #t (file-exists? (build-path mzlib-dir "compiled" "m1_rkt.zo")))
+
+;; ----------------------------------------
+;; splicing via new root directory
+
+(define new-root-dir (build-path work-dir "collects"))
+(make-directory new-root-dir)
+
+(define another-c1-dir (build-path new-root-dir "c1"))
+(make-directory another-c1-dir)
+
+(with-output-to-file (build-path another-c1-dir "m2.rkt")
+  (lambda ()
+    (printf "#lang racket/base\n'm2\n")))
+(with-output-to-file (build-path c1-dir "m3.rkt")
+  (lambda ()
+    (printf "#lang racket/base\n'm3\n")))
+
+(test null (links #:file link-file #:root? #t))
+(test (list new-root-dir) (links new-root-dir #:file link-file #:root? #t))
+
+(test-racket "'m1" '("-l" "c1/m1"))
+(test-racket "'m2" '("-l" "c1/m2"))
+(test-racket "'m3" '("-l" "c1/m3"))
+
+(run-setup "c1")
+(test #t (file-exists? (build-path c1-dir "compiled" "m1_rkt.zo")))
+(test #t (file-exists? (build-path another-c1-dir "compiled" "m2_rkt.zo")))
+(test #t (file-exists? (build-path c1-dir "compiled" "m3_rkt.zo")))
+
+;; original "c1" should take precdence over the new addition,
+;; just based on the order of addition
+
+(with-output-to-file (build-path another-c1-dir "m3.rkt")
+  (lambda ()
+    (printf "#lang racket/base\n'bad-m3\n")))
+(test-racket "'m3" '("-l" "c1/m3"))
+
+(run-setup "c1")
+;; questionable: maybe modules unreachable via `require' shouldn't be compiled:
+(test #t (file-exists? (build-path another-c1-dir "compiled" "m3_rkt.zo")))
+
+(with-output-to-file (build-path another-c1-dir "m4.rkt")
+  (lambda ()
+    (printf "#lang racket/base\n(require c1/m1)\n")))
+(test-racket "'m1" '("-l" "c1/m4"))
+
+(with-output-to-file (build-path another-c1-dir "m5.rkt")
+  (lambda ()
+    (printf "#lang racket/base\n(require c1/m3)\n")))
+(test-racket "'m3" '("-l" "c1/m5"))
+
+;; Relative path accesses a relative file --- which is inconsistent
+;; with module-path collapses, so this shouldn't be done, but
+;; check it anyway:
+(with-output-to-file (build-path another-c1-dir "m6.rkt")
+  (lambda ()
+    (printf "#lang racket/base\n(require \"m3.rkt\")\n")))
+(test-racket "'bad-m3" '("-l" "c1/m6"))
+
+;; ----------------------------------------
+;; omits in linked collections:
+
+(with-output-to-file (build-path c1-dir "info.rkt")
+  (lambda ()
+    (printf "#lang setup/infotab\n(define compile-omit-paths '(\"b1.rkt\"))\n")))
+(with-output-to-file (build-path c1-dir "b1.rkt")
+  (lambda ()
+    (printf "#lang racket/base\n'b1\n")))
+
+(with-output-to-file (build-path another-c1-dir "info.rkt")
+  (lambda ()
+    (printf "#lang setup/infotab\n(define compile-omit-paths '(\"b2.rkt\"))\n")))
+(with-output-to-file (build-path another-c1-dir "b2.rkt")
+  (lambda ()
+    (printf "#lang racket/base\n'b2\n")))
+
+(run-setup "c1")
+
+(test #f (file-exists? (build-path c1-dir "compiled" "b1_rkt.zo")))
+(test #f (file-exists? (build-path another-c1-dir "compiled" "b2_rkt.zo")))
+
+;; ----------------------------------------
+;; subcollections:
+
+(define c1/s1-dir (build-path c1-dir "s1"))
+(make-directory c1/s1-dir)
+
+(define c1/s2-dir (build-path another-c1-dir "s2"))
+(make-directory c1/s2-dir)
+
+(with-output-to-file (build-path c1/s1-dir "n1.rkt")
+  (lambda ()
+    (printf "#lang racket/base\n'n1\n")))
+
+(with-output-to-file (build-path c1/s2-dir "n2.rkt")
+  (lambda ()
+    (printf "#lang racket/base\n'n2\n")))
+
+(test-racket "'n1" '("-l" "c1/s1/n1"))
+(test-racket "'n2" '("-l" "c1/s2/n2"))
+
+(run-setup "c1/s1")
+(test #t (file-exists? (build-path c1/s1-dir "compiled" "n1_rkt.zo")))
+(run-setup "c1/s2")
+(test #t (file-exists? (build-path c1/s2-dir "compiled" "n2_rkt.zo")))
+
+;; ----------------------------------------
+;; docs in a linked collection:
+
+(with-output-to-file (build-path c1-dir "c1.scrbl")
+  (lambda ()
+    (printf "#lang scribble/manual\n@title{C1}@defmodule[c1]\n")))
+(with-output-to-file (build-path c1-dir "info.rkt")
+  #:exists 'truncate
+  (lambda ()
+    (printf "#lang setup/infotab\n(define scribblings '((\"c1.scrbl\")))\n")))
+
+(run-setup "c1")
+(test #t (file-exists? (build-path c1-dir "doc" "c1" "index.html")))
+
+;; ----------------------------------------
+;; clean up
+
+;(delete-directory/files work-dir)