avoid warnings for missing user docs

svn: r10149

collects/scribble/xref.ss

@@ -21,7 +21,8 @@
          xref-transfer-info
          (struct-out entry))
 
-(define-struct entry (words    ; list of strings: main term, sub-term, etc.
+(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
@@ -39,15 +40,13 @@
 (define (load-xref sources
                    #:render% [render% (html:render-mixin render%)]
                    #:root [root-path #f])
-  (let* ([renderer (new render%
+  (let* ([renderer (new render% [dest-dir (find-system-path 'temp-dir)])]
-                        [dest-dir (find-system-path 'temp-dir)])]
          [ci (send renderer collect null null)])
-    (for-each (lambda (src)
+    (for ([src sources])
-                (parameterize ([current-namespace (namespace-anchor->empty-namespace here)])
+      (parameterize ([current-namespace
+                      (namespace-anchor->empty-namespace here)])
         (let ([v (src)])
-                    (when v
+          (when v (send renderer deserialize-info v ci #:root root-path)))))
-                      (send renderer deserialize-info v ci #:root root-path)))))
-              sources)
     (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])))
-

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-root flags) (user-doc)]
-        [(memq 'user-doc flags)      (build-path (find-user-doc-dir) name)]
+        [(memq 'user-doc flags)      (user-doc name)]
         [(or (memq 'main-doc flags)
              (pair? (path->main-collects-relative dir)))
          (build-path (find-doc-dir) name)]

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)
+(define (get-dests)
-  (let* ([i (get-info/full dir)]
+  (for*/list ([dir (find-relevant-directories '(scribblings))]
-         [scribblings (i 'scribblings)])
+              [d ((get-info/full dir) 'scribblings)])
-    (map (lambda (d)
+    (unless (and (list? d) (pair? d))
-           (and (not (and (list? d)
+      (error 'xref "bad scribblings entry: ~e" d))
-                          ((length d) . > . 2)
+    (let* ([len   (length d)]
-                          (pair? (list-ref d 2))
+           [flags (if (len . >= . 2) (cadr d) '())]
-                          (eq? (car (list-ref d 2)) 'omit)))
+           [name  (if (len . >= . 4)
-                (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->string (path-replace-suffix
-                                   (path-replace-suffix name #"")))])
+                                   (file-name-from-path (car d)) #"")))])
-                  (build-path
+      (and (not (and (len . >= . 3) (memq 'omit (caddr d))))
-                   (doc-path dir name flags)
+           (let ([d (doc-path dir name flags #t)])
-                   "out.sxref"))))
+             (and d (build-path d "out.sxref")))))))
-         scribblings)))
 
-(define (load-collections-xref [report-loading void])
+(define (get-reader-thunks)
-  (or cached-xref
+  (map (lambda (dest)
-      (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?
+           (with-handlers ([exn:fail? (lambda (exn)
-                                                     (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 (call-with-input-file* dest fasl->s-exp)))))
-                                        (cadr r)))))
+       (filter values (get-dests))))
-                                dests)))
+
-          cached-xref))))
+(define (load-collections-xref [report-loading void])
+  (or cached-xref
+      (begin (report-loading)
+             (set! cached-xref (load-xref (get-reader-thunks)))
+             cached-xref)))