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

Lots of fixes & improvements for help

Browse Source 
svn: r8561

original commit: 0cd1cc4b08276c41216c4b73895bfa1acb52eb59
This commit is contained in:
Eli Barzilay 2008-02-07 07:59:59 +00:00
parent cbd4e8ff89
commit 43e5913612
4 changed files with 168 additions and 147 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
collects/help/help.ss
View File

@ -1,21 +1,31 @@
#lang scheme/base #lang scheme/base
(require "search.ss" (require "search.ss" scheme/cmdline)
scheme/cmdline)
(define exact-search? #f) (define go-if-one? #t)
(define exact-search? #f)
(define regexp-search? #f)
(command-line (command-line
#:once-any (["--exact" "-x"] "Go directly to the first exact hit for the search term" (set! exact-search? #t)) #:once-any
#:args search-term [("--go" "-g") "Go directly to search result if only one (default)"
(cond (set! go-if-one? #t)]
[exact-search? [("++go" "+g") "Show search results page even if only one result"
(when (null? search-term) (set! go-if-one? #t)]
(error 'plt-help "expected a search term after -x or --exact")) #:once-each
(unless (null? (cdr search-term)) [("--exact" "-x") "Search for the given term exactly"
(error 'plt-help "expected a single search term, got ~s" search-term)) (set! exact-search? #t)]
(send-exact-results (car search-term))] [("--regexp" "-r") "Search for the given regexp"
[(null? search-term) (set! regexp-search? #t)]
(send-main-page)] #:args search-terms
[else (let ([one? (= 1 (length search-terms))])
(generate-search-results search-term)])) (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?)])))

220
collects/help/search.ss
View File

@ -12,10 +12,8 @@
mzlib/contract mzlib/contract
setup/dirs) setup/dirs)
(provide/contract (provide/contract [send-main-page (-> void?)])
[generate-search-results (-> (listof string?) void?)] (provide perform-search)
[send-exact-results (-> string? void?)]
[send-main-page (-> void?)])
(define (send-main-page) (define (send-main-page)
(let* ([path (build-path (find-user-doc-dir) "index.html")] (let* ([path (build-path (find-user-doc-dir) "index.html")]
@ -23,53 +21,120 @@
path (build-path (find-doc-dir) "index.html"))]) path (build-path (find-doc-dir) "index.html"))])
(send-url/file path))) (send-url/file path)))
;; if there is exactly one exact match for this search key, go directly ;; Configuration of search results
;; to that place. Otherwise, go to a page that lists all of the matches. (define maximum-entries 500)
(define (send-exact-results search-key) (define exact-score 1000)
(let* ([file (next-search-results-file)] (define prefix-score 100)
[exact-search-regexp (regexp (format "^~a$" (regexp-quote search-key #f)))] (define suffix-score 20)
[x (load-collections-xref)] (define contain-score 10)
[index (xref-index x)] (define regexp-score-factor 1.25) ; regexps get higher score
[len (length index)] (define nomatch-score -1) ; prefer less irrelevant terms
[exact-matches (filter (has-match (list exact-search-regexp)) index)])
(if (or (null? exact-matches)
(not (null? (cdr exact-matches))))
(generate-search-results (list search-key))
(let ([match (car exact-matches)])
(let-values ([(path tag) (xref-tag->path+anchor x (entry-tag match))])
(send-url/file path #:fragment (uri-encode tag)))))))
(define (generate-search-results search-keys) (define (perform-search terms #:exact? [exact? #f] #:go-if-one? [go-if-one? #t])
(let ([file (next-search-results-file)] (if (null? terms)
[search-regexps (map (λ (x) (regexp (regexp-quote x #f))) search-keys)] (send-main-page)
[exact-search-regexps (let* ([xref (load-collections-xref)]
(map (λ (x) (regexp (format "^~a$" (regexp-quote x #f)))) search-keys)] [entries (xref-index xref)]
[search-key-string [scorer (terms->scorer terms exact?)]
(if (null? search-keys) [scored-entries
"" (let loop ([es entries] [r '()])
(apply string-append (if (null? es)
(car search-keys) r
(map (λ (x) (format ", or ~a" x)) (cdr search-keys))))]) (loop (cdr es)
(let ([x (load-collections-xref)]) (let* ([e (car es)] [score (scorer e)])
(xref-render (if (score . > . 0) (cons (cons score e) r) r)))))])
x (if (and go-if-one? (= 1 (length scored-entries)))
(decode `(,(title (format "Search results for ~a" search-key-string)) (let*-values ([(tag) (entry-tag (cdar scored-entries))]
,@(let* ([index (xref-index x)] [(path tag) (xref-tag->path+anchor xref tag)])
[len (length index)] (send-url/file path #:fragment (uri-encode tag)))
[matching-entries (filter (has-match search-regexps) index)] (let* ([file (next-search-results-file)]
[exact-matches (filter (has-match exact-search-regexps) matching-entries)] [term->label
[inexact-matches (filter (compose not (has-match exact-search-regexps)) matching-entries)]) (λ (t) (format "``~a''" (if (regexp? t) (object-name t) t)))]
(cond [search-title ; note: terms is not null at this point (see above)
[(and (null? exact-matches) (apply string-append (term->label (car terms))
(null? inexact-matches)) (map (λ (x) (format ", ~a" (term->label x)))
(list (make-element "schemeerror" (list "No results found.")))] (cdr terms)))]
[else [search-title (string-append "Search results for " search-title)]
(append [entries (map cdr (sort scored-entries scored-entry<?))]
(build-itemization "Exact matches" exact-matches) [contents
(build-itemization "Containing matches" inexact-matches))])))) (if (null? entries)
file) (list (make-element "schemeerror" (list "No results found.")))
(send-url/file file) (build-itemization entries))]
(void)))) [contents (cons (title search-title) contents)])
(xref-render xref (decode contents) file)
(send-url/file file))))))
;; converts a list of search terms to a scoring function
(define (terms->scorer terms exact?)
(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* ([sc (cond [(regexp-match? exact str) exact-score]
[exact? nomatch-score]
[(regexp-match? prefix str) prefix-score]
[(regexp-match? suffix str) suffix-score]
[(regexp-match? contain str) contain-score]
[else nomatch-score])]
[sc (if (and rx? (sc . > . 0))
(* sc regexp-score-factor)
sc)])
sc))))
terms))
(lambda (entry)
(foldl (lambda (word acc)
(+ acc (foldl (lambda (sc acc) (+ acc (sc word))) 0 scorers)))
0 (entry-words entry))))
(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 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)))))
;; 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) (define (make-extra-content desc)
;; Use `desc' to provide more details on the link: ;; Use `desc' to provide more details on the link:
@ -92,58 +157,3 @@
(map (lambda (lib) (list ", " (scheme:to-element lib))) (map (lambda (lib) (list ", " (scheme:to-element lib)))
(exported-index-desc-from-libs desc))))) (exported-index-desc-from-libs desc)))))
null))) null)))
(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)))))
;; has-match : (listof regexp) -> entry -> boolean
(define ((has-match search-regexps) entry)
(ormap (λ (str) (ormap (λ (key) (regexp-match key str)) search-regexps))
(entry-words entry)))
;; limit : exact-positive-integer
;; maximum number of hits to display
(define limit 500)
;; build-itemization : (listof entry) -> (listof <stuff>)
(define (build-itemization title entries)
(if (null? entries)
'()
(let ([entries
(sort
entries
(λ (x y) (string-ci<=? (entry->sort-key x) (entry->sort-key y))))])
(list*
(bold title)
(apply itemize
(map
(λ (entry)
(apply item
(make-link-element
"indexlink"
(entry-content entry)
(entry-tag entry))
(make-extra-content
(entry-desc entry))))
(limit-length
limit
entries)))
(if (<= (length entries) limit)
'()
(list (make-element "schemeerror"
(list (format "Search truncated after ~a hits."
limit)))))))))
(define (limit-length n l)
(cond [(null? l) '()]
[(zero? n) '()]
[else (cons (car l) (limit-length (- n 1) (cdr l)))]))
(define (entry->sort-key e)
(let ([words (entry-words e)])
(apply string-append
(car words)
(map (λ (x) (string-append ", " x)) (cdr words)))))

29
collects/scribble/html-render.ss
View File

@ -312,19 +312,22 @@
(part-parts (caar l))) (part-parts (caar l)))
(cdr l))))] (cdr l))))]
[else (cons (car l) (loop (cdr l)))])))]) [else (cons (car l) (loop (cdr l)))])))])
(if (and #f (null? toc-content)) (let* ([content (render-content
null (or (part-title-content top) '("???"))
`((div ((class "tocview")) d ri)]
(div ((class "tocviewtitle")) [content (if (null? toc-content)
(a ((href "index.html") content
(class "tocviewlink")) `((a ((href "index.html")
,@(render-content (or (part-title-content top) '("???")) d ri))) (class "tocviewlink"))
(div nbsp) ,@content)))])
,@(toc-wrap `((div ((class "tocview"))
`(table (div ((class "tocviewtitle")) ,@content)
((class "tocviewlist") (div nbsp)
(cellspacing "0")) ,@(if (null? toc-content)
,@toc-content)))))) '()
(toc-wrap
`(table ((class "tocviewlist") (cellspacing "0"))
,@toc-content)))))))
,@(render-onthispage-contents d ri top) ,@(render-onthispage-contents d ri top)
,@(apply append ,@(apply append
(map (lambda (t) (map (lambda (t)

24
collects/scribble/xref.ss
View File

@ -22,7 +22,7 @@
(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 content ; Scribble content to the index label
tag ; for generating a Scribble link tag ; for generating a Scribble link
desc)) ; further info that depends on the kind of index entry desc)) ; further info that depends on the kind of index entry
;; Private: ;; Private:
@ -63,11 +63,8 @@
(caddr v))))))) (caddr v)))))))
(define (xref-render xrefs doc dest-file #:render% [render% (html:render-mixin render%)]) (define (xref-render xrefs doc dest-file #:render% [render% (html:render-mixin render%)])
(let* ([dest-file (if (string? dest-file) (let* ([dest-file (if (string? dest-file) (string->path dest-file) dest-file)]
(string->path dest-file) [renderer (new render% [dest-dir (path-only dest-file)])]
dest-file)]
[renderer (new render%
[dest-dir (path-only dest-file)])]
[ci (send renderer collect (list doc) (list dest-file))]) [ci (send renderer collect (list doc) (list dest-file))])
(send renderer transfer-info ci (resolve-info-ci (xrefs-ri xrefs))) (send renderer transfer-info ci (resolve-info-ci (xrefs-ri xrefs)))
(let ([ri (send renderer resolve (list doc) (list dest-file) ci)]) (let ([ri (send renderer resolve (list doc) (list dest-file) ci)])
@ -121,15 +118,16 @@
(let-values ([(tag form?) (xref-binding-tag xrefs id/binding mode)]) (let-values ([(tag form?) (xref-binding-tag xrefs id/binding mode)])
tag)) tag))
(define (xref-tag->path+anchor xrefs tag #:render% [render% (html:render-mixin render%)]) (define (xref-tag->path+anchor xrefs tag
(let ([renderer (new render% #:render% [render% (html:render-mixin render%)])
[dest-dir (find-system-path 'temp-dir)])]) (send (new render% [dest-dir (find-system-path 'temp-dir)])
(send renderer tag->path+anchor (xrefs-ri xrefs) tag))) tag->path+anchor (xrefs-ri xrefs) tag))
(define (xref-tag->index-entry xrefs tag) (define (xref-tag->index-entry xrefs tag)
(let ([v (hash-table-get (collect-info-ext-ht (resolve-info-ci (xrefs-ri xrefs))) (let ([v (hash-table-get
`(index-entry ,tag) (collect-info-ext-ht (resolve-info-ci (xrefs-ri xrefs)))
#f)]) `(index-entry ,tag)
#f)])
(cond [v (make-entry (car v) (cadr v) (cadr tag) (caddr v))] (cond [v (make-entry (car v) (cadr v) (cadr tag) (caddr v))]
[(and (pair? tag) (eq? 'form (car tag))) [(and (pair? tag) (eq? 'form (car tag)))
;; Try again with 'def: ;; Try again with 'def: