diff --git a/collects/help/help.ss b/collects/help/help.ss index 300f989e..717ed1d8 100644 --- a/collects/help/help.ss +++ b/collects/help/help.ss @@ -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))) diff --git a/collects/help/search.ss b/collects/help/search.ss index 4b99d260..8061be10 100644 --- a/collects/help/search.ss +++ b/collects/help/search.ss @@ -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-entrypath+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 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 (listof ) -(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))))