diff --git a/pkgs/racket-doc/dynext/dynext.scrbl b/pkgs/racket-doc/dynext/dynext.scrbl index 75a7473eda..867278d58d 100644 --- a/pkgs/racket-doc/dynext/dynext.scrbl +++ b/pkgs/racket-doc/dynext/dynext.scrbl @@ -9,7 +9,8 @@ dynext/link-unit dynext/link-sig dynext/file-unit - dynext/file-sig)) + dynext/file-sig + compiler/module-suffix)) @title{Dynext: Running a C Compiler/Linker} @@ -359,7 +360,11 @@ Appends the platform-standard dynamic-extension file suffix to (or/c path? false/c)]{ Strips the Racket file suffix from @racket[s] and returns a stripped -path. Unlike the other functions below, when @racket[program] is not +path. The recognized suffixes are the ones reported by +@racket[(get-module-suffixes #:group 'libs)] when +@racket[extract-base-filename/ss] is first called. + +Unlike the other functions below, when @racket[program] is not @racket[#f], then any suffix (including no suffix) is allowed. If @racket[s] is not a Racket file and @racket[program] is @racket[#f], @racket[#f] is returned.} diff --git a/pkgs/racket-doc/scribblings/raco/api.scrbl b/pkgs/racket-doc/scribblings/raco/api.scrbl index e49ee75604..72db5fbe6b 100644 --- a/pkgs/racket-doc/scribblings/raco/api.scrbl +++ b/pkgs/racket-doc/scribblings/raco/api.scrbl @@ -2,6 +2,7 @@ @(require scribble/manual scribble/bnf + "common.rkt" (for-label scheme/gui compiler/compiler compiler/sig @@ -12,7 +13,9 @@ dynext/compile-sig dynext/link-sig dynext/file-sig - launcher/launcher)) + launcher/launcher + compiler/module-suffix + setup/getinfo)) @title{API for Raw Compilation} @@ -84,7 +87,9 @@ The @filepath{.zo} files are placed into the collection's By default, all files with the extension @filepath{.rkt}, @filepath{.ss}, or @filepath{.scm} in a collection are -compiled, as are all such files within subdirectories, execept that +compiled, as are all such files within subdirectories; the set of such suffixes +is extensible globally as described in @racket[get-module-suffixes], and +@racket[compile-collection-zos] recognizes suffixes from the @racket['libs] group. However, any file or directory whose path starts with @racket[skip-path] or an element of @racket[skip-paths] is skipped. (``Starts with'' means that the simplified path @racket[_p]'s byte-string form after @racket[(simplify-path _p #f)]starts with the @@ -121,15 +126,16 @@ collection. The following fields are used: @item{@indexed-racket[scribblings] : A list of pairs, each of which starts with a path for documentation source. The sources (and the files that they require) are compiled in the same way as - @filepath{.rkt}, @filepath{.ss}, and @filepath{.scm} files, - unless the provided @racket[skip-docs?] argument is a true - value.} + other module files, unless @racket[skip-docs?] is a true value.} @item{@indexed-racket[compile-include-files] : A list of filenames (without directory paths) to be compiled, in addition to files that are compiled based on the file's extension, being in @racket[scribblings], or being @racket[require]d by other compiled files.} + @item{@racket[module-suffixes] and @racket[doc-module-suffixes] --- + Used indirectly via @racket[get-module-suffixes].} + ] @history[#:changed "6.2.900.10" @elem{Added support for @racket[compile-include-files].}]} @@ -151,6 +157,68 @@ rather than a collection. The @racket[info] function behaves like the result of @racket[get-info] to supply @filepath{info.rkt} fields, instead of using an @filepath{info.rkt} file (if any) in the directory.} +@; ---------------------------------------------------------------------- + +@section[#:tag "module-suffix"]{Recognizing Module Suffixes} + +@defmodule[compiler/module-suffix]{The +@racketmodname[compiler/module-suffix] library provides functions for +recognizing file suffixes that correspond to Racket modules for the +purposes of compiling files in a directory, running tests for files in +a directory, and so on. The set of suffixes always includes +@filepath{.rkt}, @filepath{.ss}, and @filepath{.scm}, but it can be +extended globally by @filepath{info.rkt} configuration in collections.} + +@history[#:added "6.2.900.10"] + +@defproc[(get-module-suffixes [#:group group (or/c 'all 'libs 'docs) 'all] + [#:mode mode (or/c 'preferred 'all-available 'no-planet 'no-user) 'preferred] + [#:namespace namespace (or/c #f namespace?) #f]) + (listof bytes?)]{ + +Inspects @filepath{info.rkt} files (see @secref["info.rkt"]) of +installed collections to produce a list of file suffixes that should +be recognized as Racket modules. Each suffix is reported as a byte +string that does not include the @litchar{.} that precedes a suffix. + +The @racket[mode] and @racket[namespace] arguments are propagated to +@racket[find-relevant-directories] to determine which collection +directories might configure the set of suffixes. Consequently, suffix +registrations are found reliably only if @exec{raco setup} (or package +installations or updates that trigger @exec{raco setup}) is run. + +The @racket[group] argument determines whether the result includes all +registered suffixes, only those that are registered as general library +suffixes, or only those that are registered as documentation suffixes. +The set of general-library suffixes always includes @filepath{.rkt}, +@filepath{.ss}, and @filepath{.scm}. The set of documentation suffixes +always includes @filepath{.scrbl}. + +The following fields in an @filepath{info.rkt} file extend the set of +suffixes: + +@itemize[ + + @item{@indexed-racket[module-suffixes] : A list of byte strings that + correspond to general-library module suffixes (without the + @litchar{.} that must appear before the suffix). Non-lists or + non-byte-string elements of the list are ignored.} + + @item{@indexed-racket[doc-module-suffixes] : A list of byte strings + as for @racket[module-suffixes], but for documentation + modules.} + +]} + +@defproc[(get-module-suffix-regexp [#:group group (or/c 'all 'libs 'docs) 'all] + [#:mode mode (or/c 'preferred 'all-available 'no-planet 'no-user) 'preferred] + [#:namespace namespace (or/c #f namespace?) #f]) + byte-regexp?]{ + +Returns a @tech[#:doc reference-doc]{regexp value} that matches paths ending +with a suffix as reported by @racket[get-module-path-suffixes].} + + @; ---------------------------------------------------------------------- @section[#:tag "api:loading"]{Loading Compiler Support} diff --git a/pkgs/racket-doc/scribblings/raco/setup.scrbl b/pkgs/racket-doc/scribblings/raco/setup.scrbl index a36829bbcb..e2a3f2b833 100644 --- a/pkgs/racket-doc/scribblings/raco/setup.scrbl +++ b/pkgs/racket-doc/scribblings/raco/setup.scrbl @@ -22,6 +22,7 @@ setup/unpack setup/link compiler/compiler + compiler/module-suffix launcher/launcher compiler/sig launcher/launcher-sig @@ -759,6 +760,13 @@ Optional @filepath{info.rkt} fields trigger additional actions by file, etc. Supplying a specific list of collections to @exec{raco setup} disables this dependency-based deletion of compiled files.} + @item{@racket[compile-omit-paths], @racket[compile-omit-files], and + @racket[compile-include-files] --- Used indirectly via + @racket[compile-collection-zos].} + +@item{@racket[module-suffixes] and @racket[doc-module-suffixes] --- + Used indirectly via @racket[get-module-suffixes].} + ] @; ------------------------------------------------------------------------ diff --git a/racket/collects/compiler/compiler.rkt b/racket/collects/compiler/compiler.rkt index b18800e63e..d6728b5e07 100644 --- a/racket/collects/compiler/compiler.rkt +++ b/racket/collects/compiler/compiler.rkt @@ -90,10 +90,11 @@ (compile-to-zo f zo n prefix verbose? mod?))))) (define (compile-directory-visitor dir info worker omit-root - #:verbose [verbose? #t] - #:skip-path [orig-skip-path #f] - #:skip-paths [orig-skip-paths null] - #:skip-doc-sources? [skip-docs? #f]) + #:verbose verbose? + #:has-module-suffix? has-module-suffix? + #:skip-path orig-skip-path + #:skip-paths orig-skip-paths + #:skip-doc-sources? skip-docs?) (define info* (or info (lambda (key mk-default) (mk-default)))) (define omit-paths (omitted-paths dir c-get-info/full omit-root)) (define skip-paths (for/list ([p (in-list (if orig-skip-path @@ -128,7 +129,7 @@ (cons -inf.0 "")))))))))]) (let* ([sses (append ;; Find all .rkt/.ss/.scm files: - (filter extract-base-filename/ss (directory-list)) + (filter has-module-suffix? (directory-list)) ;; Add specified doc sources: (if skip-docs? null @@ -155,8 +156,9 @@ #:skip-doc-sources? skip-docs?) init)))) init)))) - (define (compile-directory dir info - #:verbose [verbose? #t] + (define (compile-directory dir info + #:has-module-suffix? [has-module-suffix? extract-base-filename/ss] + #:verbose [verbose? #t] #:skip-path [orig-skip-path #f] #:skip-paths [orig-skip-paths null] #:skip-doc-sources? [skip-docs? #f] @@ -166,29 +168,30 @@ (define (worker prev sses) (for-each managed-compile-zo sses)) (compile-directory-visitor dir info worker omit-root + #:has-module-suffix? has-module-suffix? #:verbose verbose? #:skip-path orig-skip-path #:skip-paths orig-skip-paths #:skip-doc-sources? skip-docs?)) - (define (get-compile-directory-srcs dir info + (define (get-compile-directory-srcs dir info + #:has-module-suffix? [has-module-suffix? extract-base-filename/ss] #:verbose [verbose? #t] #:skip-path [orig-skip-path #f] #:skip-paths [orig-skip-paths null] #:skip-doc-sources? [skip-docs? #f] - #:managed-compile-zo [managed-compile-zo - (make-caching-managed-compile-zo)] #:omit-root [omit-root dir]) (compile-directory-visitor dir info append omit-root + #:has-module-suffix? has-module-suffix? #:verbose verbose? #:skip-path orig-skip-path #:skip-paths orig-skip-paths - #:skip-doc-sources? skip-docs? - #:managed-compile-zo managed-compile-zo)) + #:skip-doc-sources? skip-docs?)) (define unspec (gensym)) - (define (compile-collection-zos collection + (define (compile-collection-zos collection + #:has-module-suffix? [has-module-suffix? extract-base-filename/ss] #:skip-path [skip-path #f] #:skip-paths [skip-paths null] #:skip-doc-sources? [skip-docs? #f] @@ -202,6 +205,7 @@ #:omit-root (if (eq? omit-root unspec) dir omit-root) + #:has-module-suffix? has-module-suffix? #:verbose #f #:skip-path skip-path #:skip-paths skip-paths diff --git a/racket/collects/compiler/module-suffix.rkt b/racket/collects/compiler/module-suffix.rkt new file mode 100644 index 0000000000..f600ef7967 --- /dev/null +++ b/racket/collects/compiler/module-suffix.rkt @@ -0,0 +1,58 @@ +#lang racket/base +(require racket/list + racket/string + setup/getinfo + racket/contract/base) + +(provide + (contract-out + [get-module-suffixes (() + (#:mode (or/c 'preferred 'all-available 'no-planet 'no-user) + #:group (or/c 'all 'libs 'docs) + #:namespace (or/c #f namespace?)) + . ->* . + (listof bytes?))] + [get-module-suffix-regexp (() + (#:mode (or/c 'preferred 'all-available 'no-planet 'no-user) + #:group (or/c 'all 'libs 'docs) + #:namespace (or/c #f namespace?)) + . ->* . + byte-regexp?)])) + +(define (get-module-suffixes #:mode [key 'preferred] + #:group [group 'all] + #:namespace [namespace #f]) + (define fields (case group + [(all) '(module-suffixes doc-module-suffixes)] + [(libs) '(module-suffixes)] + [(docs) '(doc-module-suffixes)])) + (define dirs (find-relevant-directories fields key)) + (define rkt-ht (if (memq 'module-suffixes fields) + (hash #"rkt" #t #"ss" #t #"scm" #t) + (hash))) + (define init-ht (if (memq 'doc-module-suffixes fields) + (hash-set rkt-ht #"scrbl" #t) + rkt-ht)) + (define ht + (for/fold ([ht init-ht]) ([dir (in-list dirs)]) + (define info (get-info/full dir #:namespace namespace)) + (for/fold ([ht init-ht]) ([field (in-list fields)]) + (define suffixes (info field (lambda () null))) + (cond + [(list? suffixes) + (for/fold ([ht ht]) ([suffix (in-list suffixes)]) + (cond + [(bytes? suffix) (hash-set ht suffix #t)] + [else ht]))])))) + (sort (hash-keys ht) bytesbytes (appender (bytes->path #"x"))) 1)) -(define-values (extract-base-filename/ss - extract-base-filename/c - extract-base-filename/kp - extract-base-filename/o - extract-base-filename/ext) - (let ([mk - (lambda (who pat kind simple) - (define (extract-base-filename s [p #f]) - (define rx - (byte-pregexp (bytes-append #"^(.*)\\.(?i:" pat #")$"))) - (unless (path-string? s) - (raise-type-error who "path or valid-path string" s)) - (cond [(regexp-match - rx (path->bytes (if (path? s) s (string->path s)))) - => (lambda (m) (bytes->path (cadr m)))] - [p (if simple - (error p "not a ~a filename (doesn't end with ~a): ~a" - kind simple s) - (path-replace-suffix s #""))] - [else #f])) - extract-base-filename)]) - (values - (mk 'extract-base-filename/ss #"rkt|ss|scm" "Racket" #f) - (mk 'extract-base-filename/c - #"c|cc|cxx|cpp|c[+][+]|m" "C" ".c, .cc, .cxx, .cpp, .c++, or .m") - (mk 'extract-base-filename/kp #"kp" "constant pool" ".kp") - (mk 'extract-base-filename/o - (case (system-type) - [(unix beos macos macosx) #"o"] - [(windows) #"obj"]) - "compiled object" - (extract-suffix append-object-suffix)) - (mk 'extract-base-filename/ext - (regexp-quote (subbytes (system-type 'so-suffix) 1) #f) - "Racket extension" - (extract-suffix append-extension-suffix))))) +(define (extract-rx pat) + (byte-pregexp (bytes-append #"^(.*)\\.(?i:" pat #")$"))) + +(define (extract who s program rx kind simple) + (unless (path-string? s) + (raise-argument-error who "path-string?" s)) + (cond + [(regexp-match rx (if (path? s) s (string->path s))) + => (lambda (m) (bytes->path (cadr m)))] + [program + (if simple + (error program "not a ~a filename (doesn't end with ~a): ~a" + kind simple s) + (path-replace-suffix s #""))] + [else #f])) + +(define module-suffix-regexp + (delay (get-module-suffix-regexp #:group 'libs))) + +(define (extract-base-filename/ss s [program #f] + #:module-pattern [module-pattern + (force module-suffix-regexp)]) + (extract 'extract-base-filename/ss + s program + module-pattern + "Racket" + #f)) + +(define (extract-base-filename/c s [program #f]) + (extract 'extract-base-filename/c + s program + (extract-rx #"c|cc|cxx|cpp|c[+][+]|m") + "C" + ".c, .cc, .cxx, .cpp, .c++, or .m")) + +(define (extract-base-filename/kp s [program #f]) + (extract 'extract-base-filename/kp + s + program + (extract-rx #"kp") + "constant pool" + ".kp")) + +(define (extract-base-filename/o s [program #f]) + (extract 'extract-base-filename/o + s program + (case (system-type) + [(unix beos macos macosx) #"o"] + [(windows) #"obj"]) + "compiled object" + (extract-suffix append-object-suffix))) + +(define (extract-base-filename/ext s [program #f]) + (extract 'extract-base-filename/ext + s + program + (regexp-quote (subbytes (system-type 'so-suffix) 1) #f) + "Racket extension" + (extract-suffix append-extension-suffix))) diff --git a/racket/collects/setup/getinfo.rkt b/racket/collects/setup/getinfo.rkt index a29c9530f8..0c81b0e0cb 100644 --- a/racket/collects/setup/getinfo.rkt +++ b/racket/collects/setup/getinfo.rkt @@ -1,7 +1,7 @@ #lang racket/base (require racket/match - racket/contract + racket/contract/base planet/cachepath syntax/modread "dirs.rkt" diff --git a/racket/collects/setup/setup-core.rkt b/racket/collects/setup/setup-core.rkt index ad384af12e..12303c5342 100644 --- a/racket/collects/setup/setup-core.rkt +++ b/racket/collects/setup/setup-core.rkt @@ -20,7 +20,7 @@ compiler/compiler (prefix-in compiler:option: compiler/option) launcher/launcher - dynext/file + compiler/module-suffix "unpack.rkt" "getinfo.rkt" @@ -508,7 +508,7 @@ (let loop ([l collections-to-compile]) (append-map (lambda (cc) (cons cc (loop (get-subs cc)))) l)))) - (define (collection-tree-map collections-to-compile) + (define (collection-tree-map collections-to-compile has-module-suffix?) (define (build-collection-tree cc) (define (make-child-cc parent-cc name) (collection-cc! (append (cc-collection parent-cc) (list name)) @@ -540,7 +540,7 @@ (filter-map (lambda (x) (make-child-cc cc x)) dirs))) (define srcs (append - (filter extract-base-filename/ss files) + (filter has-module-suffix? files) (if make-docs? (filter (lambda (p) (not (member p omit))) (map (lambda (s) (if (string? s) (string->path s) s)) @@ -984,7 +984,7 @@ ;; and it makes a do-nothing setup complete much faster. (define caching-managed-compile-zo (make-caching-managed-compile-zo)) - (define (compile-cc cc gcs) + (define (compile-cc cc gcs has-module-suffix?) (parameterize ([current-namespace (make-base-empty-namespace)]) (begin-record-error cc "making" (setup-printf "making" "~a" (cc-name cc)) @@ -999,6 +999,7 @@ (define dir (cc-path cc)) (define info (cc-info cc)) (compile-directory-zos dir info + #:has-module-suffix? has-module-suffix? #:omit-root (cc-omit-root cc) #:managed-compile-zo caching-managed-compile-zo #:skip-path (and (avoid-main-installation) main-collects-dir) @@ -1025,6 +1026,14 @@ (case where [(beginning) (append same diff)] [(end) (append diff same)]))) + (define has-module-suffix? + (let ([rx (get-module-suffix-regexp + #:mode (cond + [(make-user) 'preferred] + [else 'no-user]) + #:group 'libs + #:namespace info-ns)]) + (lambda (p) (regexp-match? rx p)))) (setup-printf #f "--- compiling collections ---") (if ((parallel-workers) . > . 1) (begin @@ -1034,24 +1043,25 @@ (when (and (cc-main? cc) (member (cc-info-root cc) (current-library-collection-paths))) - (compile-cc cc 0)))) + (compile-cc cc 0 has-module-suffix?)))) (with-specified-mode (lambda () (define cct (move-to 'beginning (list #rx"/compiler$" #rx"/raco$" #rx"/racket$" #rx"/images/") (move-to 'end (list #rx"/drracket") (sort-collections-tree - (collection-tree-map top-level-plt-collects))))) + (collection-tree-map top-level-plt-collects + has-module-suffix?))))) (iterate-cct clean-cc cct) (parallel-compile (parallel-workers) setup-fprintf handle-error cct) (for/fold ([gcs 0]) ([cc planet-dirs-to-compile]) - (compile-cc cc gcs))))) + (compile-cc cc gcs has-module-suffix?))))) (with-specified-mode (lambda () (for ([cc ccs-to-compile]) (clean-cc cc)) (for/fold ([gcs 0]) ([cc ccs-to-compile]) - (compile-cc cc gcs)))))) + (compile-cc cc gcs has-module-suffix?)))))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Info-Domain Cache ;;