suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

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

Browse Source 
svn: r8577

original commit: 7539945a3dd567b0dae31b824af751b0ef4ff2a5
This commit is contained in:
Eli Barzilay 2008-02-08 04:32:49 +00:00
parent 1b2c9f88dd
commit b9aadb5dc6
4 changed files with 51 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
collects/help/search.ss
View File

@ -26,12 +26,12 @@
(define exact-score 1000)
(define exact-word-score 600)
(define words1-score 400)
(define words2-score 200)
(define prefix-score 100)
(define words2-score 100)
(define prefix-score 200)
(define suffix-score 20)
(define contain-score 10)
(define exported-entry-bonus 200) ; prefer bindings and modules
(define regexp-score-factor 1.25) ; regexps get higher score
(define exported-entry-factor 1.1) ; prefer bindings and modules
(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)))
(let* ([file (next-search-results-file)]
[term->label
(send-url/file path #:fragment (and tag (uri-encode tag))))
(let* ([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/file file))))))
(send-url/contents (xref-render xref (decode contents) #f)
#: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)
(+ acc (foldl (lambda (sc acc) (+ acc (sc word))) 0 scorers)))
;; give some bonus for bindings and modules
(let ([desc (entry-desc entry)])
(if (or (exported-index-desc? desc) (module-path-index-desc? desc))
exported-entry-bonus 0))
(entry-words entry))))
(let ([sc (foldl (lambda (word acc)
(+ acc (foldl (lambda (sc acc) (+ acc (sc word)))
0 scorers)))
0
(entry-words entry))])
;; give some bonus for bindings and modules
(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))]))])))
(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)))))
[else (string-ci<? (car xs) (car ys))]))])))
;; build-itemization : (nonempty-listof entry) -> (listof <stuff>)
(define (build-itemization entries)

10
collects/scribble/base-render.ss
View File

@ -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
(lambda () (render-one d ri fn))))
(if 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))

34
collects/scribble/xref.ss
View File

@ -53,23 +53,27 @@
(define (xref-index xrefs)
(filter
values
(hash-table-map (collect-info-ext-ht (resolve-info-ci (xrefs-ri xrefs)))
(lambda (k v)
(and (pair? k)
(eq? (car k) 'index-entry)
(make-entry (car v)
(cadr v)
(cadr k)
(caddr v)))))))
(hash-table-map
(collect-info-ext-ht (resolve-info-ci (xrefs-ri xrefs)))
(lambda (k v)
(and (pair? k)
(eq? (car k) 'index-entry)
(make-entry (car v) (cadr 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)])]
[ci (send renderer collect (list doc) (list dest-file))])
(send renderer transfer-info ci (resolve-info-ci (xrefs-ri xrefs)))
(let ([ri (send renderer resolve (list doc) (list dest-file) ci)])
(send renderer render (list doc) (list dest-file) ri)
(void))))
[renderer (new render% [dest-dir (and dest-file (path-only dest-file))]
[css-path 'inline])]
[ci (send renderer collect (list doc) (list dest-file))]
[_ (send renderer transfer-info ci (resolve-info-ci (xrefs-ri xrefs)))]
[ri (send renderer resolve (list doc) (list dest-file) ci)]
[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

4
collects/scribblings/scribble/xref.scrbl
View File

@ -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?])