much improved search, extended and fixed sendurl, string-based rendering for xrefs

svn: r8577

original commit: 7539945a3dd567b0dae31b824af751b0ef4ff2a5

collects/help/search.ss

@@ -26,12 +26,12 @@
 (define exact-score 1000)
 (define exact-word-score 600)
 (define words1-score 400)
-(define words2-score 200)
+(define words2-score 100)
-(define prefix-score 100)
+(define prefix-score 200)
 (define suffix-score  20)
 (define contain-score 10)
-(define exported-entry-bonus 200) ; prefer bindings and modules
+(define exported-entry-factor 1.1) ; prefer bindings and modules
-(define regexp-score-factor 1.25) ; regexps get higher score
+(define regexp-score-factor 1.1) ; regexps get higher score
 (define nomatch-score -1) ; prefer less irrelevant terms
 
 (define (perform-search terms #:exact? [exact? #f] #:go-if-one? [go-if-one? #t])
@@ -47,13 +47,15 @@
                 (loop (cdr es)
                       (let* ([e (car es)] [score (scorer e)])
                         (if (score . > . 0) (cons (cons score e) r) r)))))]
+           ;; use to debug weird search results
+           ;; [_ (for ([x (sort entries scored-entry<?)])
+           ;;      (printf "~a ~s\n" (car x) (entry-words (cdr x))))]
            [entries (map cdr (sort entries scored-entry<?))])
       (if (and go-if-one? (= 1 (length entries)))
         (let*-values ([(tag) (entry-tag (car entries))]
                       [(path tag) (xref-tag->path+anchor xref tag)])
-          (send-url/file path #:fragment (uri-encode tag)))
+          (send-url/file path #:fragment (and tag (uri-encode tag))))
-        (let* ([file (next-search-results-file)]
+        (let* ([term->label
-               [term->label
                 (λ (t) (format "``~a''" (if (regexp? t) (object-name t) t)))]
                [search-title ; note: terms is not null at this point (see above)
                 (apply string-append (term->label (car terms))
@@ -65,8 +67,8 @@
                   (list (make-element "schemeerror" (list "No results found.")))
                   (build-itemization entries))]
                [contents (cons (title search-title) contents)])
-          (xref-render xref (decode contents) file)
+          (send-url/contents (xref-render xref (decode contents) #f)
-          (send-url/file file))))))
+                             #:delete-at (* 60 10)))))))
 
 ;; converts a list of search terms to a scoring function
 (define (terms->scorer terms exact?)
@@ -108,13 +110,16 @@
                  sc))))
          terms))
   (lambda (entry)
-    (foldl (lambda (word acc)
+    (let ([sc (foldl (lambda (word acc)
-             (+ acc (foldl (lambda (sc acc) (+ acc (sc word))) 0 scorers)))
+                       (+ acc (foldl (lambda (sc acc) (+ acc (sc word)))
-           ;; give some bonus for bindings and modules
+                                     0 scorers)))
-           (let ([desc (entry-desc entry)])
+                     0
-             (if (or (exported-index-desc? desc) (module-path-index-desc? desc))
+                     (entry-words entry))])
-               exported-entry-bonus 0))
+      ;; give some bonus for bindings and modules
-           (entry-words entry))))
+      (let ([desc (entry-desc entry)])
+        (if (or (exported-index-desc? desc) (module-path-index-desc? desc))
+          (* sc exported-entry-factor)
+          sc)))))
 
 (define (scored-entry<? x y)
   (let ([xsc (car x)] [ysc (car y)])
@@ -128,14 +133,7 @@
                          (or (loop (cdr xs) (cdr ys))
                              ;; Try string<? so "Foo" still precedes "foo"
                              (string<? (car xs) (car ys)))]
-                        [else (string-ci<? (car xs) (car xs))]))])))
+                        [else (string-ci<? (car xs) (car ys))]))])))
-
-
-(define next-search-results-file
-  (let ([n -1] [tmp (find-system-path 'temp-dir)])
-    (lambda ()
-      (set! n (modulo (add1 n) 10))
-      (build-path tmp (format "search-results-~a.html" n)))))
 
 ;; build-itemization : (nonempty-listof entry) -> (listof <stuff>)
 (define (build-itemization entries)

collects/scribble/base-render.ss

@@ -279,9 +279,15 @@
 
     (define/public (render ds fns ri)
       (map (lambda (d fn)
+             (define (one) (render-one d ri fn))
              (when report-output? (printf " [Output to ~a]\n" fn))
-             (with-output-to-file fn #:exists 'truncate/replace
+             (if fn
-               (lambda () (render-one d ri fn))))
+               (with-output-to-file fn #:exists 'truncate/replace one)
+               ;; a #f filename means return the contents as a string
+               (let ([o (open-output-string)])
+                 (parameterize ([current-output-port o])
+                   (one)
+                   (get-output-string o)))))
            ds
            fns))
 

collects/scribble/xref.ss

@@ -53,23 +53,27 @@
 (define (xref-index xrefs)
   (filter
    values
-   (hash-table-map (collect-info-ext-ht (resolve-info-ci (xrefs-ri xrefs)))
+   (hash-table-map
-                   (lambda (k v)
+    (collect-info-ext-ht (resolve-info-ci (xrefs-ri xrefs)))
-                     (and (pair? k)
+    (lambda (k v)
-                          (eq? (car k) 'index-entry)
+      (and (pair? k)
-                          (make-entry (car v) 
+           (eq? (car k) 'index-entry)
-                                      (cadr v)
+           (make-entry (car v) (cadr v) (cadr k) (caddr v)))))))
-                                      (cadr k)
-                                      (caddr v)))))))
 
-(define (xref-render xrefs doc dest-file #:render% [render% (html:render-mixin render%)])
+;; dest-file can be #f, which will make it return a string holding the
+;; resulting html
+(define (xref-render xrefs doc dest-file
+                     #:render% [render% (html:render-mixin render%)])
   (let* ([dest-file (if (string? dest-file) (string->path dest-file) dest-file)]
-         [renderer (new render% [dest-dir (path-only dest-file)])]
+         [renderer (new render% [dest-dir (and dest-file (path-only dest-file))]
-         [ci (send renderer collect (list doc) (list dest-file))])
+                                [css-path 'inline])]
-    (send renderer transfer-info ci (resolve-info-ci (xrefs-ri xrefs)))
+         [ci (send renderer collect (list doc) (list dest-file))]
-    (let ([ri (send renderer resolve (list doc) (list dest-file) ci)])
+         [_ (send renderer transfer-info ci (resolve-info-ci (xrefs-ri xrefs)))]
-      (send renderer render (list doc) (list dest-file) ri)
+         [ri (send renderer resolve (list doc) (list dest-file) ci)]
-      (void))))
+         [xs (send renderer render (list doc) (list dest-file) ri)])
+    (if dest-file
+      (void)
+      (car xs))))
 
 ;; Returns (values <tag-or-#f> <form?>)
 (define xref-binding-tag

collects/scribblings/scribble/xref.scrbl

@@ -106,7 +106,7 @@ which might be used with @scheme[xref-tag->path+anchor] or embedded in
 a document rendered via @scheme[xref-render]. If no definition point
 is found in @scheme[xref], the result is @scheme[#f].}
 
-                                                  
+
 @defproc[(xref-tag->path+anchor [xref xref?]
                                 [tag tag?]
                                 [#:render% using-render% (subclass?/c render%)
@@ -123,7 +123,7 @@ point in a page.
 
 The optional @scheme[using-render%] argument is as for
 @scheme[load-xref].}
-                                
+
 
 @defproc[(xref-tag->index-entry [xref xref?]
                                 [tag tag?])