From 3dc1dc80e3cd11dfdc8d21f7f5df90bd63c78287 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 30 Jul 2015 09:25:29 -0600 Subject: [PATCH] add setup/collection-search --- pkgs/racket-doc/scribblings/raco/setup.scrbl | 45 ++++++++++ .../scribblings/reference/collects.scrbl | 6 +- .../tests/setup/collection-search.rkt | 61 ++++++++++++++ racket/collects/setup/collection-search.rkt | 83 +++++++++++++++++++ 4 files changed, 194 insertions(+), 1 deletion(-) create mode 100644 pkgs/racket-test/tests/setup/collection-search.rkt create mode 100644 racket/collects/setup/collection-search.rkt diff --git a/pkgs/racket-doc/scribblings/raco/setup.scrbl b/pkgs/racket-doc/scribblings/raco/setup.scrbl index f20bed0c5d..a36829bbcb 100644 --- a/pkgs/racket-doc/scribblings/raco/setup.scrbl +++ b/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.} @; ------------------------------------------------------------------------ diff --git a/pkgs/racket-doc/scribblings/reference/collects.scrbl b/pkgs/racket-doc/scribblings/reference/collects.scrbl index 89aa10bead..627e7ee501 100644 --- a/pkgs/racket-doc/scribblings/reference/collects.scrbl +++ b/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 diff --git a/pkgs/racket-test/tests/setup/collection-search.rkt b/pkgs/racket-test/tests/setup/collection-search.rkt new file mode 100644 index 0000000000..a9f1cb81bc --- /dev/null +++ b/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))))))) diff --git a/racket/collects/setup/collection-search.rkt b/racket/collects/setup/collection-search.rkt new file mode 100644 index 0000000000..9438b56a81 --- /dev/null +++ b/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)))) +