commit 38ad7672e413b646b400485819ee25caff4fdda6
parent b9c84b4cc7b88e7bec4f83af6ee323727d5e99cb
Author: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 6 Jun 2008 13:24:58 +0000
change the way Scribble generates keys based on modules
svn: r10170
original commit: 21fd7b93b3f332b1c4272b87b6f286846c26a790
Diffstat:
5 files changed, 66 insertions(+), 61 deletions(-)
diff --git 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
@@ -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
@@ -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
@@ -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/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?
