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

No more Scheme-based searching, all in the browser now.

Browse Source 
(Most code removed.)

svn: r10096

original commit: 3a06e4a3014615125d275a260ef7a04d5e62d871
This commit is contained in:
Eli Barzilay 2008-06-02 23:36:22 +00:00
parent 24fc7f2806
commit 232306e535
2 changed files with 20 additions and 200 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
collects/help/help.ss
View File

@ -1,31 +1,15 @@
#lang scheme/base
(require "search.ss" scheme/cmdline)
(define go-if-one? #t)
(define exact-search? #f)
(define regexp-search? #f)
(require "search.ss" scheme/cmdline scheme/list)
;; Minimal command-line arguments, the query string can contain all
;; kinds of magic.
(command-line
#:once-any
[("--go" "-g") "Go directly to search result if only one (default)"
(set! go-if-one? #t)]
[("--no-go" "-G") "Show search results page even if only one result"
(set! go-if-one? #t)]
#:once-each
[("--exact" "-x") "Search for the given term exactly"
(set! exact-search? #t)]
[("--regexp" "-r") "Search for the given regexp"
(set! regexp-search? #t)]
#:args search-terms
(let ([one? (= 1 (length search-terms))])
(cond [(and regexp-search? (not one?))
(error 'plt-help "expected a single regexp after -r or --regexp")]
[(and exact-search? (not one?))
(error 'plt-help "expected a single search term after -x or --exact")]
[(null? search-terms) (send-main-page)]
[else (perform-search (if regexp-search?
(list (regexp (car search-terms)))
search-terms)
#:exact? (or exact-search? regexp-search?)
#:go-if-one? go-if-one?)])))
#:handlers
(lambda (_ . ts)
(perform-search (apply string-append (add-between ts " "))))
'("search-terms")
(lambda (help-str)
(display help-str)
(display " See the search page for the syntax of queries\n")
(exit 0)))

182
collects/help/search.ss
View File

@ -1,178 +1,14 @@
#lang scheme/base
(require setup/xref
scribble/xref
scribble/struct
scribble/manual-struct
scribble/decode
scribble/manual
(prefix-in scheme: scribble/scheme)
net/sendurl
net/uri-codec
mzlib/contract
setup/dirs)
(provide/contract [send-main-page (-> void?)])
(require setup/dirs net/sendurl)
(provide perform-search)
(define (send-main-page)
(let* ([path (build-path (find-user-doc-dir) "index.html")]
(define search-page "search/index.html")
;; Almost nothing to do here -- the real work is done in the browser,
;; using javascript.
(define (perform-search str)
(let* ([path (build-path (find-user-doc-dir) search-page)]
[path (if (file-exists? path)
path (build-path (find-doc-dir) "index.html"))])
(send-url/file path)))
;; Configuration of search results
(define maximum-entries 500)
(define exact-score 1000)
(define prefix-score 200)
(define suffix-score 20)
(define contain-score 10)
(define words-factor 0.9)
(define exported-entry-factor 1.1) ; prefer bindings and modules
(define regexp-score-factor 1.1) ; regexps get higher score
(define nomatch-score -5) ; prefer less irrelevant terms
(define (perform-search terms #:exact? [exact? #f] #:go-if-one? [go-if-one? #t])
(if (null? terms)
(send-main-page)
(let* ([xref (load-collections-xref)]
[scorer (terms->scorer terms exact?)]
[entries (xref-index xref)]
[entries
(let loop ([es entries] [r '()])
(if (null? es)
r
(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 (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))
(map (λ (x) (format ", ~a" (term->label x)))
(cdr terms)))]
[search-title (string-append "Search results for " search-title)]
[contents
(if (null? entries)
(list (make-element "schemeerror" (list "No results found.")))
(build-itemization entries))]
[contents (cons (title search-title) contents)])
(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? [words? #f])
;; turns a string to one that matches word prefixes (eg turn a "reg-qu"
;; string to "reg\\w*-qu\\w*"), as with convenient completers like Emacs or
;; zsh.
(define (collect-words strings)
(apply append (map (lambda (t) (regexp-match* #px"\\w+" t))
(filter string? strings))))
(define scorers
(map (lambda (term)
(let* ([rx? (regexp? term)]
[rx (if rx? (object-name term) (regexp-quote term #f))]
;; note: still works if we're given a regexp with ^/$ anchors
[exact (regexp (format "^~a$" rx))]
[prefix (regexp (format "^~a" rx))]
[suffix (regexp (format "~a$" rx))]
[contain (if rx? term (regexp rx))])
(lambda (str)
(let* ([match? (lambda (rx sc)
(if (and rx (regexp-match? rx str)) sc 0))]
[sc (if exact?
(match? exact exact-score)
(+ (match? exact exact-score)
(match? prefix prefix-score)
(match? suffix suffix-score)
(match? contain contain-score)))]
[sc (cond [(sc . <= . 0) nomatch-score]
[rx? (* sc regexp-score-factor)]
[else sc])])
sc))))
terms))
(define word-scorer
(and (not words?) (not exact?) (terms->scorer (collect-words terms) #f #t)))
(lambda (entry)
(let* ([words (entry-words entry)]
[words (if words? (collect-words words) words)]
[sc (foldl (lambda (word acc)
(+ acc (foldl (lambda (sc acc) (+ acc (sc word)))
0 scorers)))
0
words)])
(if words?
sc
(let ([desc (entry-desc entry)]
[sc (+ sc (* words-factor (word-scorer entry)))])
;; give some bonus for bindings and modules
(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)])
(cond [(> xsc ysc) #t]
[(< xsc ysc) #f]
[else (let loop ([xs (entry-words (cdr x))]
[ys (entry-words (cdr y))])
(cond [(null? ys) #f]
[(null? xs) #t]
[(string-ci=? (car xs) (car ys))
(or (loop (cdr xs) (cdr ys))
;; Try string<? so "Foo" still precedes "foo"
(string<? (car xs) (car ys)))]
[else (string-ci<? (car xs) (car ys))]))])))
;; build-itemization : (nonempty-listof entry) -> (listof <stuff>)
(define (build-itemization entries)
(define entries*
(if (<= (length entries) maximum-entries)
entries
(let loop ([n maximum-entries] [es entries] [r '()])
(if (or (null? es) (zero? n))
(reverse r)
(loop (sub1 n) (cdr es) (cons (car es) r))))))
(cons (apply itemize
(map (λ (entry)
(apply item
(make-link-element "indexlink"
(entry-content entry)
(entry-tag entry))
(make-extra-content (entry-desc entry))))
entries*))
(if (eq? entries* entries)
'()
(list (make-element "schemeerror"
(list (format "Search truncated after ~a hits."
maximum-entries)))))))
(define (make-extra-content desc)
;; Use `desc' to provide more details on the link:
(append
(if (method-index-desc? desc)
(list " method of "
;; This is bad. We need a more abstract way to take a
;; binding name and tag/source to create a Scheme link.
(make-element
"schemesymbol"
(list (make-link-element
"schemevaluelink"
(list (symbol->string (exported-index-desc-name desc)))
(method-index-desc-class-tag desc)))))
null)
(if (and (exported-index-desc? desc)
(not (null? (exported-index-desc-from-libs desc))))
(cons ", provided from "
(cdr (apply append
(map (lambda (lib) (list ", " (scheme:to-element lib)))
(exported-index-desc-from-libs desc)))))
null)))
path (build-path (find-doc-dir) search-page))])
(send-url/file path #:query (format "q=~a" str))))