suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

avoid warnings for missing user docs

Browse Source 
svn: r10149
This commit is contained in:
Eli Barzilay 2008-06-05 16:34:53 +00:00
parent a3c2d438de
commit ae09de2fa2
3 changed files with 52 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
collects/scribble/xref.ss
View File

@ -21,10 +21,11 @@
xref-transfer-info
(struct-out entry))
(define-struct entry (words ; list of strings: main term, sub-term, etc.
content ; Scribble content to the index label
tag ; for generating a Scribble link
desc)) ; further info that depends on the kind of index entry
(define-struct entry
(words ; list of strings: main term, sub-term, etc.
content ; Scribble content to the index label
tag ; for generating a Scribble link
desc)) ; further info that depends on the kind of index entry
;; Private:
(define-struct xrefs (renderer ri))
@ -36,18 +37,16 @@
(define-namespace-anchor here)
(define (load-xref sources
(define (load-xref sources
#:render% [render% (html:render-mixin render%)]
#:root [root-path #f])
(let* ([renderer (new render%
[dest-dir (find-system-path 'temp-dir)])]
(let* ([renderer (new render% [dest-dir (find-system-path 'temp-dir)])]
[ci (send renderer collect null null)])
(for-each (lambda (src)
(parameterize ([current-namespace (namespace-anchor->empty-namespace here)])
(let ([v (src)])
(when v
(send renderer deserialize-info v ci #:root root-path)))))
sources)
(for ([src sources])
(parameterize ([current-namespace
(namespace-anchor->empty-namespace here)])
(let ([v (src)])
(when v (send renderer deserialize-info v ci #:root root-path)))))
(make-xrefs renderer (send renderer resolve null null ci))))
;; ----------------------------------------
@ -147,4 +146,3 @@
;; Try again with 'def:
(xref-tag->index-entry xrefs (cons 'def (cdr tag)))]
[else #f])))

11
collects/setup/private/path-utils.ss
View File

@ -8,10 +8,15 @@
(provide doc-path path->name)
(define (doc-path dir name flags)
(define (doc-path dir name flags [false-if-missing-user-doc? #f])
(define (user-doc [sub #f])
(let ([d (find-user-doc-dir)])
(and (or (not false-if-missing-user-doc?)
(directory-exists? d))
(if sub (build-path d sub) d))))
(cond [(memq 'main-doc-root flags) (find-doc-dir)]
[(memq 'user-doc-root flags) (find-user-doc-dir)]
[(memq 'user-doc flags) (build-path (find-user-doc-dir) name)]
[(memq 'user-doc-root flags) (user-doc)]
[(memq 'user-doc flags) (user-doc name)]
[(or (memq 'main-doc flags)
(pair? (path->main-collects-relative dir)))
(build-path (find-doc-dir) name)]

71
collects/setup/xref.ss
View File

@ -1,52 +1,45 @@
#lang scheme/base
(require scribble/xref
setup/getinfo
scheme/fasl
scheme/path
"getinfo.ss"
"private/path-utils.ss")
(provide load-collections-xref)
(define cached-xref #f)
(define (get-dests dir)
(let* ([i (get-info/full dir)]
[scribblings (i 'scribblings)])
(map (lambda (d)
(and (not (and (list? d)
((length d) . > . 2)
(pair? (list-ref d 2))
(eq? (car (list-ref d 2)) 'omit)))
(pair? d)
(let* ([flags (if (pair? (cdr d)) (cadr d) null)]
[name (if (and (pair? (cdr d)) (pair? (cddr d))
(pair? (cdddr d)))
(cadddr d)
(let-values ([(base name dir?) (split-path (car d))])
(path-replace-suffix name #"")))])
(build-path
(doc-path dir name flags)
"out.sxref"))))
scribblings)))
(define (get-dests)
(for*/list ([dir (find-relevant-directories '(scribblings))]
[d ((get-info/full dir) 'scribblings)])
(unless (and (list? d) (pair? d))
(error 'xref "bad scribblings entry: ~e" d))
(let* ([len (length d)]
[flags (if (len . >= . 2) (cadr d) '())]
[name (if (len . >= . 4)
(cadddr d)
(path->string (path-replace-suffix
(file-name-from-path (car d)) #"")))])
(and (not (and (len . >= . 3) (memq 'omit (caddr d))))
(let ([d (doc-path dir name flags #t)])
(and d (build-path d "out.sxref")))))))
(define (get-reader-thunks)
(map (lambda (dest)
(lambda ()
(with-handlers ([exn:fail? (lambda (exn)
(fprintf (current-error-port)
"WARNING: ~a\n"
(if (exn? exn)
(exn-message exn)
(format "~e" exn)))
#f)])
(cadr (call-with-input-file* dest fasl->s-exp)))))
(filter values (get-dests))))
(define (load-collections-xref [report-loading void])
(or cached-xref
(begin
(report-loading)
(let* ([dests (map get-dests (find-relevant-directories '(scribblings)))]
[dests (filter values (apply append dests))])
(set! cached-xref
(load-xref (map (lambda (dest)
(lambda ()
(with-handlers ([exn:fail?
(lambda (exn)
(fprintf (current-error-port)
"WARNING: ~a\n"
(if (exn? exn)
(exn-message exn)
(format "~e" exn)))
#f)])
(let ([r (call-with-input-file* dest fasl->s-exp)])
(cadr r)))))
dests)))
cached-xref))))
(begin (report-loading)
(set! cached-xref (load-xref (get-reader-thunks)))
cached-xref)))