add setup/collection-search

pkgs/racket-doc/scribblings/raco/setup.scrbl

@@ -12,6 +12,7 @@
                     setup/getinfo
                     setup/main-collects
                     setup/collection-name
+                    setup/collection-search
                     setup/matching-platform
                     setup/path-to-relative
                     setup/xref scribble/xref
@@ -1714,6 +1715,50 @@ is not the ASCII value of a letter, digit, @litchar{-}, @litchar{+},
 or @litchar{_}.}
 
 
+@; ------------------------------------------------------------------------
+
+@section[#:tag "collection-search"]{API for Collection Searches}
+
+@defmodule[setup/collection-search]
+
+@history[#:added "6.2.900.6"]
+
+@defproc[(collection-search [mod-path normalized-lib-module-path?]
+                            [#:init result any/c #f]
+                            [#:combine combine (any/c (and/c path? complete-path?) . -> . any/c) (lambda (r v) v)]
+                            [#:break? break? (any/c . -> . any/c) (lambda (r) #f)]
+                            [#:all-possible-roots? all-possible-roots? any/c #f])
+         any/c]{
+
+Generalizes @racket[collection-file-path] to support folding over all
+possible locations of a collection-based file in the current
+configuration. Unlike @racket[collection-file-path],
+@racket[collection-search] takes the file to location in module-path
+form, but always as a @racket['lib] path.
+
+Each possible path for the file (not counting a @filepath{.ss} to/from
+@filepath{.rkt} conversion) is provided as a second argument to the
+@racket[combine] function, where the first argument is the current
+result, and the value produced by @racket[combine] becomes the new
+result. The @racket[#:init] argument provides the initial result.
+
+The @racket[break?] function short-circuits a search based on the
+current value. For example, it could be used to short-circuit a search
+after a suitable path is found.
+
+If @racket[all-possible-roots?] is @racket[#f], then @racket[combine]
+is called only on paths within @filepath{collects}-like directories
+(for the current configuration) where at least a matching collection
+directory exists.}
+
+
+@defproc[(normalized-lib-module-path? [v any/c]) boolean?]{
+
+Returns @racket[#t] if @racket[v] is a module path (in the sense of
+@racket[module-path?]) of the form @racket['(lib _str)] where
+@racket[_str] contains at least one slash. The
+@racket[collapse-module-path] function produces such module paths for
+collection-based module references.}
 
 @; ------------------------------------------------------------------------
 

pkgs/racket-doc/scribblings/reference/collects.scrbl

@@ -1,6 +1,7 @@
 #lang scribble/doc
 @(require "mz.rkt"
-          (for-label setup/dirs))
+          (for-label setup/dirs
+                     setup/collection-search))
 
 @title[#:tag "collects"]{Libraries and Collections}
 
@@ -264,6 +265,9 @@ collection specified by the @racket[collection]s, where the second
 search uses the values of @racket[current-library-collection-links]
 and @racket[current-library-collection-paths].
 
+@margin-note{See also @racket[collection-search] in
+             @racketmodname[setup/collection-search].}
+
 If @racket[file] is not found, but @racket[file] ends in
 @filepath{.rkt} and a file with the suffix @filepath{.ss} exists, then
 the directory of the @filepath{.ss} file is used. If @racket[file] is

pkgs/racket-test/tests/setup/collection-search.rkt

@@ -0,0 +1,61 @@
+#lang racket
+(require setup/collection-search
+         compiler/compilation-path
+         syntax/modcollapse
+         rackunit
+         pkg/lib
+         pkg/path
+         setup/getinfo
+         racket/format
+         setup/collection-name)
+
+(define (check-search-finds-one mp)
+  (printf "try ~s\n" mp)
+  (define norm-mp (collapse-module-path mp 'racket))
+  (check-equal? (list
+                 (resolved-module-path-name
+                  (module-path-index-resolve
+                   (module-path-index-join mp #f))))
+                (collection-search norm-mp
+                                   #:init null
+                                   #:combine (lambda (r n)
+                                               (if (or (file-exists? n)
+                                                       (file-exists? (get-compilation-bytecode-file n)))
+                                                   (cons n r)
+                                                   r)))))
+
+(for-each check-search-finds-one 
+          (list 'racket
+                'racket/base
+                'compiler/compilation-path
+                'tests/compiler/collection-search))
+
+;; Try to find a module in every installed collection:
+(define cache (make-hash))
+(for ([s (get-all-pkg-scopes)])
+  (for ([(name info) (in-hash (installed-pkg-table #:scope s))])
+    (define dir (pkg-directory name #:cache cache))
+    (define info (get-info/full dir))
+    (define collection (and info
+                            (info 'collection (lambda () 'use-pkg-name))))
+    (define-values (coll coll-dir)
+      (cond
+       [(eq? collection 'multi)
+        (let loop ([l (directory-list dir)])
+          (cond
+           [(null? l) (values #f #f)]
+           [(and (collection-name-element? (path->string (car l)))
+                 (directory-exists? (build-path dir (car l))))
+            (values (car l) (build-path dir (car l)))]
+           [else (loop (cdr l))]))]
+       [(string? collection)
+        (values collection dir)]
+       [else
+        (values name dir)]))
+    (when coll
+      (define file (for/first ([l (directory-list coll-dir)]
+                               #:when (and (regexp-match? #rx"[.]rkt$" l)
+                                           (not (equal? (path->string l) "info.rkt"))))
+                     l))
+      (when file
+        (check-search-finds-one `(lib ,(~a coll "/" file)))))))

racket/collects/setup/collection-search.rkt

@@ -0,0 +1,83 @@
+#lang racket/base
+(require racket/list
+         racket/string)
+
+(provide collection-search
+         normalized-lib-module-path?)
+           
+(define (collection-search mp
+                           #:combine [combine (lambda (r v) v)]
+                           #:init [result #f]
+                           #:break? [break? (lambda (r) #f)]
+                           #:all-possible-roots? [all-possible-roots? #f])
+  (unless (normalized-lib-module-path? mp)
+    (error 'collection-search "normalized-lib-module-path?" mp))
+  (define els (string-split (cadr mp) "/"))
+  (define coll-str (car els))
+  (define coll-sym (string->symbol coll-str))
+  (define subpath (apply build-path els))
+  (define subsubpath (apply build-path (cdr els)))
+  (define (build-path* b p) (simplify-path (build-path b p)))
+  (define (check-root p result all-possible-roots?)
+    (define coll-dir (build-path* p coll-str))
+    (if (or all-possible-roots?
+            (directory-exists? coll-dir))
+        (combine result (build-path coll-dir subsubpath))
+        result))
+  (for/fold ([result result]) ([p (in-list (current-library-collection-links))]
+                               #:break (break? result))
+    (cond
+     [(not p)
+      (for/fold ([result result]) ([r (in-list (current-library-collection-paths))]
+                                   #:break (break? result))
+        (check-root r result all-possible-roots?))]
+     [(path? p)
+      (define content
+        (with-handlers ([exn:fail? (lambda (exn)
+                                     (log-error "error attempting to read links file: ~a"
+                                                (exn-message exn))
+                                     null)])
+          (if (file-exists? p)
+              (call-with-default-reading-parameterization
+               (lambda ()
+                 (call-with-input-file* p read)))
+              null)))
+      (define-values (links-dir base dir?) (split-path p))
+      (for/fold ([result result]) ([e (in-list content)]
+                                   #:break (break? result)
+                                   #:when
+                                   (and (list? e)
+                                        (or (= (length e) 2)
+                                            (and (= (length e) 3)
+                                                 (regexp? (caddr e))))
+                                        (path-string? (cadr e))
+                                        (or (null? (cddr e))
+                                            (regexp-match? (caddr e) (version)))))
+        (let ([a (car e)]
+              [p (path->complete-path (cadr e) links-dir)])
+          (cond
+           [(or (eq? 'root a)
+                (eq? 'static-root a))
+            (check-root p result (and (eq? 'root a)
+                                      all-possible-roots?))]
+           [(equal? coll-str a)
+            (combine result (build-path* p subsubpath))]
+           [else result])))]
+     [(hash? p)
+      (or (for/fold ([result result]) ([r (in-list (hash-ref p coll-sym null))]
+                                       #:break (break? result))
+            (combine result (build-path* r subsubpath)))
+          (for/fold ([result result]) ([r (in-list (hash-ref p #f null))]
+                                       #:break (break? result))
+            (check-root r result all-possible-roots?)))]
+     [else
+      (error 'collection-search
+             "internal error: unexpected collection-link list element")])))
+    
+(define (normalized-lib-module-path? mp)
+  (and (module-path? mp)
+       (pair? mp)
+       (eq? 'lib (car mp))
+       (= 2 (length mp))
+       (regexp-match? #rx"/" (cadr mp))))
+