From ae09de2fa2cb15c37cd14eb858aed64071ce53f3 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 5 Jun 2008 16:34:53 +0000 Subject: [PATCH] avoid warnings for missing user docs svn: r10149 --- collects/scribble/xref.ss | 26 +++++----- collects/setup/private/path-utils.ss | 11 +++-- collects/setup/xref.ss | 71 +++++++++++++--------------- 3 files changed, 52 insertions(+), 56 deletions(-) diff --git a/collects/scribble/xref.ss b/collects/scribble/xref.ss index 3a648262f2..f4b7d438f1 100644 --- a/collects/scribble/xref.ss +++ b/collects/scribble/xref.ss @@ -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]))) - diff --git a/collects/setup/private/path-utils.ss b/collects/setup/private/path-utils.ss index da8fe3387b..a41cc30a9c 100644 --- a/collects/setup/private/path-utils.ss +++ b/collects/setup/private/path-utils.ss @@ -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)] diff --git a/collects/setup/xref.ss b/collects/setup/xref.ss index 41bf64eef6..65cff722c4 100644 --- a/collects/setup/xref.ss +++ b/collects/setup/xref.ss @@ -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)))