From 21fd7b93b3f332b1c4272b87b6f286846c26a790 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 6 Jun 2008 13:24:58 +0000 Subject: [PATCH] change the way Scribble generates keys based on modules svn: r10170 --- collects/compiler/compiler-unit.ss | 4 +- collects/scribble/manual.ss | 20 ++--- collects/scribble/scheme.ss | 2 +- collects/scribble/search.ss | 74 ++++++++++++----- collects/scribble/xref.ss | 27 ++---- collects/scribblings/reference/syntax.scrbl | 31 +++++-- collects/scribblings/scribble/xref.scrbl | 4 +- .../scribblings/setup-plt/setup-plt.scrbl | 4 +- collects/setup/pack.ss | 2 +- collects/setup/scribble.ss | 31 ++++--- collects/setup/setup-unit.ss | 4 +- collects/setup/xref.ss | 2 +- collects/syntax/modcollapse.ss | 83 +++++++++++++++++-- src/mzscheme/src/module.c | 9 +- 14 files changed, 203 insertions(+), 94 deletions(-) diff --git a/collects/compiler/compiler-unit.ss b/collects/compiler/compiler-unit.ss index 82bef710d5..e8c9acc1b8 100644 --- a/collects/compiler/compiler-unit.ss +++ b/collects/compiler/compiler-unit.ss @@ -183,7 +183,9 @@ (let ([s (path->string p)]) ;; this is the same check that setup/setup-unit is doing in ;; `make-cc*' - (unless (or (regexp-match? #rx"^[.]" s) (equal? "compiled" s) + (unless (or (regexp-match? #rx"^[.]" s) + (equal? "compiled" s) + (equal? "doc" s) (and (pair? omit-paths) (member s omit-paths))) (let ([p (build-path dir p)]) (compile-directory p (get-info/full p))))))))) diff --git a/collects/scribble/manual.ss b/collects/scribble/manual.ss index 54430d7f72..8ca8b40f18 100644 --- a/collects/scribble/manual.ss +++ b/collects/scribble/manual.ss @@ -394,12 +394,8 @@ (and (checker id) lib))) (or source-libs null)) (and (pair? libs) (car libs)))]) - (and lib (let ([p (resolved-module-path-name - (module-path-index-resolve - (module-path-index-join lib #f)))]) - (if (path? p) - (intern-taglet (path->main-collects-relative p)) - p))))) + (and lib (module-path-index->taglet + (module-path-index-join lib #f))))) (define (id-to-target-maker id dep?) (*id-to-target-maker 'def id dep?)) @@ -452,10 +448,8 @@ (lambda () (car content)))))) (define (make-binding-redirect-elements mod-path redirects) - (let ([taglet (path->main-collects-relative - (resolved-module-path-name - (module-path-index-resolve - (module-path-index-join mod-path #f))))]) + (let ([taglet (module-path-index->taglet + (module-path-index-join mod-path #f))]) (make-element #f (map @@ -1980,11 +1974,7 @@ (define (id-info id) (let ([b (identifier-label-binding id)]) (if b - (list (let ([p (resolved-module-path-name (module-path-index-resolve - (caddr b)))]) - (if (path? p) - (intern-taglet (path->main-collects-relative p)) - p)) + (list (caddr b) (list-ref b 3) (list-ref b 4) (list-ref b 5) diff --git a/collects/scribble/scheme.ss b/collects/scribble/scheme.ss index 4adf2cf551..98b2a200fd 100644 --- a/collects/scribble/scheme.ss +++ b/collects/scribble/scheme.ss @@ -77,7 +77,7 @@ (let* ([key (and id-element-cache (let ([b (identifier-label-binding c)]) (vector (syntax-e c) - (module-path-index-resolve (caddr b)) + (module-path-index->taglet (caddr b)) (cadddr b) (list-ref b 5))))]) (or (and key diff --git a/collects/scribble/search.ss b/collects/scribble/search.ss index dd6df55fe8..6702a6901f 100644 --- a/collects/scribble/search.ss +++ b/collects/scribble/search.ss @@ -2,10 +2,16 @@ (require "struct.ss" "basic.ss" setup/main-collects - syntax/modcode) + syntax/modcode + syntax/modcollapse + + ;; Needed to normalize planet version numbers: + (only-in planet/resolver get-planet-module-path/pkg) + (only-in planet/private/data pkg-maj pkg-min)) (provide find-scheme-tag - intern-taglet) + intern-taglet + module-path-index->taglet) (define module-info-cache (make-hasheq)) @@ -34,7 +40,35 @@ (hash-set! interned v (make-weak-box v)) v))) v))) - + + (define (module-path-index->taglet mod) + ;; Derive the name from the module path: + (let ([p (collapse-module-path-index + mod + (current-directory))]) + (if (path? p) + ;; If we got a path back anyway, then it's best to use the resolved + ;; name; if the current directory has changed since we + ;; the path-index was resolved, then p might not be right + (intern-taglet + (path->main-collects-relative + (resolved-module-path-name (module-path-index-resolve mod)))) + (let ([p (if (and (pair? p) + (eq? (car p) 'planet)) + ;; Normalize planet verion number based on current + ;; linking: + (let-values ([(path pkg) + (get-planet-module-path/pkg p #f #f)]) + (list* 'planet + (cadr p) + (list (car (caddr p)) + (cadr (caddr p)) + (pkg-maj pkg) + (pkg-min pkg)) + (cdddr p))) + ;; Otherwise the path is fully normalized: + p)]) + (intern-taglet p))))) (define (find-scheme-tag part ri stx/binding phase-level) ;; The phase-level argument is used only when `stx/binding' @@ -59,22 +93,19 @@ stx/binding] [else (and (not (symbol? (car stx/binding))) - (let ([p (module-path-index-join - (main-collects-relative->path (car stx/binding)) - #f)]) - (list #f - (cadr stx/binding) - p - (cadr stx/binding) - (if (= 2 (length stx/binding)) - 0 - (caddr stx/binding)) - (if (= 2 (length stx/binding)) - 0 - (cadddr stx/binding)) - (if (= 2 (length stx/binding)) - 0 - (cadddr (cdr stx/binding))))))])]) + (list #f + (cadr stx/binding) + (car stx/binding) + (cadr stx/binding) + (if (= 2 (length stx/binding)) + 0 + (caddr stx/binding)) + (if (= 2 (length stx/binding)) + 0 + (cadddr stx/binding)) + (if (= 2 (length stx/binding)) + 0 + (cadddr (cdr stx/binding)))))])]) (and (pair? b) (let ([seen (make-hasheq)] @@ -96,10 +127,7 @@ [queue (cdr queue)]) (let* ([rmp (module-path-index-resolve mod)] [eb (and (equal? 0 export-phase) ;; look for the phase-0 export; good idea? - (list (let ([p (resolved-module-path-name rmp)]) - (if (path? p) - (intern-taglet (path->main-collects-relative p)) - p)) + (list (module-path-index->taglet mod) id))]) (when (and eb (not search-key)) diff --git a/collects/scribble/xref.ss b/collects/scribble/xref.ss index f4b7d438f1..aba49abf56 100644 --- a/collects/scribble/xref.ss +++ b/collects/scribble/xref.ss @@ -104,25 +104,14 @@ (= 2 (length id/binding))) (let loop ([src (car id/binding)]) (cond - [(path? src) - (if (complete-path? src) - (search (list src (cadr id/binding))) - (loop (path->complete-path src)))] - [(path-string? src) - (loop (path->complete-path src))] - [(resolved-module-path? src) - (let ([n (resolved-module-path-name src)]) - (if (pair? n) - (loop n) - (search n)))] - [(module-path-index? src) - (loop (module-path-index-resolve src))] - [(module-path? src) - (loop (module-path-index-join src #f))] - [else - (raise-type-error 'xref-binding-definition->tag - "list starting with module path, resolved module path, module path index, path, or string" - src)]))] + [(module-path-index? src) + (search src)] + [(module-path? src) + (loop (module-path-index-join src #f))] + [else + (raise-type-error 'xref-binding-definition->tag + "list starting with module path or module path index" + src)]))] [else (raise-type-error 'xref-binding-definition->tag "identifier, 2-element list, or 7-element list" id/binding)]))])) diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index 04418ad979..466d58a248 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -206,16 +206,19 @@ Legal only in a @tech{module begin context}, and handled by the (planet id) (planet string) (planet rel-string - (user-string pkg-string vers ...) + (user-string pkg-string vers) rel-string ...)] [id-maybe-renamed id [orig-id bind-id]] [phase-level exact-integer #f] - [vers nat - (nat nat) - (= nat) - (+ nat) - (- nat)])]{ + [vers code:blank + nat + (code:line nat minor-vers)] + [minor-vers nat + (nat nat) + ((unsyntax (schemeidfont "=")) nat) + ((unsyntax (schemeidfont "+")) nat) + ((unsyntax (schemeidfont "-")) nat)])]{ In a @tech{top-level context}, @scheme[require] instantiates modules (see @secref["module-eval-model"]). In a @tech{module context}, @@ -374,7 +377,7 @@ corresponds to the default @tech{module name resolver}. @defsubform*[((planet id) (planet string) - (planet rel-string (user-string pkg-string vers ...) + (planet rel-string (user-string pkg-string vers) rel-string ...))]{ Specifies a library available via the @PLaneT server. @@ -415,8 +418,18 @@ corresponds to the default @tech{module name resolver}. In the more general last form of a @scheme[planet] module path, the @scheme[rel-string]s are similar to the @scheme[lib] form, except - that the @scheme[(user-string pkg-string vers ...)] names a - @|PLaneT|-based package instead of a @tech{collection}.} + that the @scheme[(user-string pkg-string vers)] names a + @|PLaneT|-based package instead of a @tech{collection}. A version + specification can include an optional major and minor version, where + the minor version can be a specific number or a constraint: + @scheme[(_nat _nat)] specifies an inclusive range, @scheme[((unsyntax + (schemeidfont "=")) _nat)] specifies an exact match, + @scheme[((unsyntax (schemeidfont "+")) _nat)] specifies a minimum + version and is equivalent to just @scheme[_nat], and + @scheme[((unsyntax (schemeidfont "-")) _nat)] specifies a maximum + version. The @schemeidfont{=}, @schemeidfont{+}, and @schemeidfont{-} + identifiers in a minor-version constraint are recognized + symbolically.} No identifier can be bound multiple times in a given @tech{phase level} by an import, unless all of the bindings refer to the same diff --git a/collects/scribblings/scribble/xref.scrbl b/collects/scribblings/scribble/xref.scrbl index 1188f027db..aa6ec6eed3 100644 --- a/collects/scribblings/scribble/xref.scrbl +++ b/collects/scribblings/scribble/xref.scrbl @@ -46,9 +46,7 @@ get all cross-reference information for installed documentation.} @defproc[(xref-binding->definition-tag [xref xref?] [binding (or/c identifier? (list/c (or/c module-path? - module-path-index? - path? - resolved-module-path?) + module-path-index?) symbol?) (listof module-path-index? symbol? diff --git a/collects/scribblings/setup-plt/setup-plt.scrbl b/collects/scribblings/setup-plt/setup-plt.scrbl index 8cdb6a0113..9f9e0d7705 100644 --- a/collects/scribblings/setup-plt/setup-plt.scrbl +++ b/collects/scribblings/setup-plt/setup-plt.scrbl @@ -675,8 +675,8 @@ for making @filepath{.plt} archives:} Returns @scheme[#t] unless @scheme[p], after stripping its directory path and converting to a byte string, matches one of the following regular expressions: @litchar{^CVS$}, @litchar{^[.]svn$}, - @litchar{^[.]cvsignore}, @litchar{^compiled$}, @litchar{~$}, @litchar{^#.*#$}, - @litchar{^[.]#}, or @litchar{[.]plt$}.} + @litchar{^[.]cvsignore}, @litchar{^compiled$}, @litchar{^doc}, + @litchar{~$}, @litchar{^#.*#$}, @litchar{^[.]#}, or @litchar{[.]plt$}.} @defproc[(mztar (path path-string?) (output output-port?) diff --git a/collects/setup/pack.ss b/collects/setup/pack.ss index aa712c5a8e..5ecee107fc 100644 --- a/collects/setup/pack.ss +++ b/collects/setup/pack.ss @@ -178,7 +178,7 @@ (define (std-filter path) (let-values ([(base name dir?) (split-path path)]) (let ([name (path->bytes name)]) - (not (or (regexp-match #rx#"^(?:CVS|[.]svn|[.]cvsignore|compiled)$" + (not (or (regexp-match #rx#"^(?:CVS|[.]svn|[.]cvsignore|compiled|doc)$" name) (regexp-match #rx#"~$|^#.*#$|^[.]#" name) (regexp-match #rx#"[.]plt$" name)))))) diff --git a/collects/setup/scribble.ss b/collects/setup/scribble.ss index 184241d50e..9acccc22c0 100644 --- a/collects/setup/scribble.ss +++ b/collects/setup/scribble.ss @@ -20,7 +20,7 @@ (define verbose (make-parameter #t)) -(define-struct doc (src-dir src-file dest-dir flags under-main? category)) +(define-struct doc (src-dir src-spec src-file dest-dir flags under-main? category)) (define-struct info (doc sci provides undef searches deps build? time out-time need-run? need-in-write? need-out-write? @@ -55,7 +55,7 @@ (define (scribblings-flag? sym) (memq sym '(main-doc main-doc-root user-doc-root user-doc multi-page depends-all depends-all-main no-depend-on always-run))) - (define (validate-scribblings-infos infos dir) + (define (validate-scribblings-infos infos) (define (validate path [flags '()] [cat '(library)] [name #f]) (and (string? path) (relative-path? path) (list? flags) (andmap scribblings-flag? flags) @@ -74,8 +74,9 @@ (apply validate i))) infos)]) (and (not (memq #f infos)) infos)))) - (define (get-docs i dir) - (let ([s (validate-scribblings-infos (i 'scribblings) dir)]) + (define (get-docs i rec) + (let ([s (validate-scribblings-infos (i 'scribblings))] + [dir (directory-record-path rec)]) (if s (map (lambda (d) (let* ([flags (cadr d)] @@ -86,6 +87,14 @@ (or (memq 'main-doc flags) (pair? (path->main-collects-relative dir))))]) (make-doc dir + (let ([spec (directory-record-spec rec)]) + (list* (car spec) + (car d) + (if (eq? 'planet (car spec)) + (list (append (cdr spec) + (list (directory-record-maj rec) + (list '= (directory-record-min rec))))) + (cdr spec)))) (build-path dir (car d)) (doc-path dir (cadddr d) flags) flags under-main? (caddr d)))) @@ -95,9 +104,9 @@ "bad 'scribblings info: ~e from: ~e" (i 'scribblings) dir) null)))) (define docs - (let* ([dirs (find-relevant-directories '(scribblings))] - [infos (map get-info/full dirs)]) - (filter-user-docs (append-map get-docs infos dirs) make-user?))) + (let* ([recs (find-relevant-directory-records '(scribblings) 'all-available)] + [infos (map get-info/full (map directory-record-path recs))]) + (filter-user-docs (append-map get-docs infos recs) make-user?))) (define-values (main-docs user-docs) (partition doc-under-main? docs)) (define (can-build*? docs) (can-build? only-dirs docs)) (define auto-main? (and auto-start-doc? (ormap can-build*? main-docs))) @@ -396,7 +405,7 @@ (lambda () (parameterize ([current-directory (doc-src-dir doc)]) (let* ([v (ensure-doc-prefix - (dynamic-require-doc (doc-src-file doc)) + (dynamic-require-doc (doc-src-spec doc)) (doc-src-file doc))] [dest-dir (pick-dest latex-dest doc)] [ci (send renderer collect (list v) (list dest-dir))] @@ -459,7 +468,7 @@ (parameterize ([current-directory (doc-src-dir doc)]) (let* ([v (ensure-doc-prefix (render-time "load" - (dynamic-require-doc (doc-src-file doc))) + (dynamic-require-doc (doc-src-spec doc))) (doc-src-file doc))] [dest-dir (pick-dest latex-dest doc)] [ci (render-time "collect" @@ -524,7 +533,7 @@ (parameterize ([current-namespace (namespace-anchor->empty-namespace anchor)]) (thunk))) -(define (dynamic-require-doc path) +(define (dynamic-require-doc mod-path) ;; Use a separate namespace so that we don't end up with all the ;; documentation loaded at once. ;; Use a custodian to compensate for examples executed during the build @@ -540,7 +549,7 @@ ;; hard-wiring the "manual.ss" library: (namespace-attach-module ns 'scribble/manual p) (parameterize ([current-namespace p]) - (call-in-nested-thread (lambda () (dynamic-require path 'doc))))))) + (call-in-nested-thread (lambda () (dynamic-require mod-path 'doc))))))) (define (write- info name sel) (let* ([doc (info-doc info)] diff --git a/collects/setup/setup-unit.ss b/collects/setup/setup-unit.ss index 2ce4689f5a..8a4d3de197 100644 --- a/collects/setup/setup-unit.ss +++ b/collects/setup/setup-unit.ss @@ -187,7 +187,9 @@ "ignoring `compile-subcollections' entry in info ~a\n" path-name)) ;; this check is also done in compiler/compiler-unit, in compile-directory - (and (not (or (regexp-match? #rx"^[.]" basename) (equal? "compiled" basename) + (and (not (or (regexp-match? #rx"^[.]" basename) + (equal? "compiled" basename) + (equal? "doc" basename) (eq? 'all (info 'compile-omit-paths void)))) (make-cc collection path (if name (string-append path-name " (" name ")") path-name) diff --git a/collects/setup/xref.ss b/collects/setup/xref.ss index 65cff722c4..443a25e927 100644 --- a/collects/setup/xref.ss +++ b/collects/setup/xref.ss @@ -11,7 +11,7 @@ (define cached-xref #f) (define (get-dests) - (for*/list ([dir (find-relevant-directories '(scribblings))] + (for*/list ([dir (find-relevant-directories '(scribblings) 'all-available)] [d ((get-info/full dir) 'scribblings)]) (unless (and (list? d) (pair? d)) (error 'xref "bad scribblings entry: ~e" d)) diff --git a/collects/syntax/modcollapse.ss b/collects/syntax/modcollapse.ss index 241718865d..36e2dca384 100644 --- a/collects/syntax/modcollapse.ss +++ b/collects/syntax/modcollapse.ss @@ -1,7 +1,9 @@ (module modcollapse mzscheme (require mzlib/list + scheme/string mzlib/contract + (only scheme/base regexp-split) "private/modhelp.ss") (define (collapse-module-path s relto-mp) @@ -100,23 +102,94 @@ (loop s2))))]) (let ([m (regexp-match #rx"^(.*)/([^/]*)$" simpler)]) (if m - `(lib ,(caddr m) ,(cadr m)) + (normalize-lib `(lib ,(caddr m) ,(cadr m))) (error 'combine-relative-elements "relative path escapes collection: ~s relative to ~s" elements relto-mp))))))] [(eq? (car relto-mp) 'planet) (let ([pathstr (attach-to-relative-path-string elements (cadr relto-mp))]) - `(planet ,pathstr ,(caddr relto-mp)))] + (normalize-planet `(planet ,pathstr ,(caddr relto-mp))))] [else (error 'combine-relative-elements "don't know how to deal with: ~s" relto-mp)])) + (define (normalize-lib s) + (if (null? (cddr s)) + ;; single-string version: + (let ([e (cadr s)]) + (cond + [(regexp-match? #rx"[.]" e) + ;; It has a suffix: + (if (regexp-match? #rx"/" e) + ;; It has a path, so it's fine: + s + ;; No path, so add "mzlib/": + `(lib ,(string-append "mzlib/" e)))] + [(regexp-match? #rx"/" e) + ;; It has a separator, so add a suffix: + `(lib ,(string-append e ".ss"))] + [else + ;; No separator or suffix, so add "/main.ss": + `(lib ,(string-append e "/main.ss"))])) + ;; multi-string version: + (if (regexp-match? #rx"[.]" (cadr s)) + ;; there's a suffix, so we can collapse to a single string: + `(lib ,(string-join (append (cddr s) + (list (cadr s))) + "/")) + ;; No suffix, so we must keep the old style: + s))) + + (define (normalize-planet s) + (cond + [(symbol? (cadr s)) + ;; normalize via string form: + (normalize-planet `(planet ,(symbol->string (cadr s))))] + [(null? (cddr s)) + ;; normalize to long form: + (let* ([strs (regexp-split #rx"/" (cadr s))]) + (let ([owner (car strs)] + [pkg+vers (regexp-split #rx":" (cadr strs))] + [path (cddr strs)]) + `(planet ,(if (null? path) + "main.ss" + (let ([str (car (last-pair path))]) + (if (regexp-match? #rx"[.]" str) + str + (string-append str ".ss")))) + (,owner + ,(car pkg+vers) + ,@(if (null? (cdr pkg+vers)) + null + `(,(string->number (cadr pkg+vers)) + ,(let ([vers (caddr pkg+vers)]) + (cond + [(regexp-match? #rx"<=" vers) + `(- ,(string->number (substring vers 2)))] + [(regexp-match? #rx">=" vers) + `(+ ,(string->number (substring vers 2)))] + [(regexp-match? #rx"=" vers) + (string->number (substring vers 1))] + [(regexp-match #rx"(.*)-(.*)" vers) + => (lambda (m) + `(,(string->number (cadr m)) + ,(string->number (caddr m))))] + [else (error 'collapse-module-path + "confused when normalizing planet path: ~e" + s)]))))) + ,@(if (null? path) + null + (reverse (cdr (reverse path)))))))] + [else + ;; Long form is the normal form: + s])) + (cond [(string? s) ;; Parse Unix-style relative path string (combine-relative-elements (explode-relpath-string s))] [(symbol? s) ;; Convert to `lib' form: - `(lib ,(symbol->string s))] + (normalize-lib `(lib ,(symbol->string s)))] [(and (or (not (pair? s)) (not (list? s))) (not (path? s))) #f] [(or (path? s) (eq? (car s) 'file)) @@ -128,8 +201,8 @@ (cond [(eq? base 'relative) (combine-relative-elements (cons name elements))] [else (loop base (cons name elements))])))))] - [(eq? (car s) 'lib) s] - [(eq? (car s) 'planet) s] + [(eq? (car s) 'lib) (normalize-lib s)] + [(eq? (car s) 'planet) (normalize-planet s)] [(eq? (car s) 'quote) s] [else #f])) diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index 3b41e964af..49f17290f1 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -2054,7 +2054,7 @@ int scheme_is_module_path(Scheme_Object *obj) } } else if (SAME_OBJ(SCHEME_CAR(obj), planet_symbol)) { Scheme_Object *a, *subs; - int len; + int len, counter; len = scheme_proper_list_length(obj); @@ -2096,11 +2096,15 @@ int scheme_is_module_path(Scheme_Object *obj) if (!ok_planet_string(a)) return 0; + /* planet allows a major and minor version number: */ + counter = 0; for (obj = SCHEME_CDR(obj); !SCHEME_NULLP(obj); obj = SCHEME_CDR(obj)) { + if (counter == 2) + return 0; a = SCHEME_CAR(obj); if (ok_planet_number(a)) { /* ok */ - } else if (SCHEME_PAIRP(a)) { + } else if ((counter == 1) && SCHEME_PAIRP(a)) { if (scheme_proper_list_length(a) != 2) return 0; if (ok_planet_number(SCHEME_CAR(a))) { @@ -2127,6 +2131,7 @@ int scheme_is_module_path(Scheme_Object *obj) return 0; } else return 0; + counter++; } for (; !SCHEME_NULLP(subs); subs = SCHEME_CDR(subs)) {