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

removed help/* leftovers that are not used in v4

Browse Source 
svn: r8528

original commit: 5dd18dadcb4b7634c3035abf4f6f0d87fd65ae90
This commit is contained in:
Eli Barzilay 2008-02-04 19:59:39 +00:00
parent 58fa3c4dfc
commit 750e18115c
1 changed files with 53 additions and 75 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

128
collects/help/search.ss
View File

@ -13,9 +13,9 @@
setup/dirs) setup/dirs)
(provide/contract (provide/contract
[generate-search-results (-> (listof string?) void?)] [generate-search-results (-> (listof string?) void?)]
[send-exact-results (-> string? void?)] [send-exact-results (-> string? void?)]
[send-main-page (-> 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")]
@ -32,28 +32,24 @@
[index (xref-index x)] [index (xref-index x)]
[len (length index)] [len (length index)]
[exact-matches (filter (has-match (list exact-search-regexp)) index)]) [exact-matches (filter (has-match (list exact-search-regexp)) index)])
(cond (if (or (null? exact-matches)
[(or (null? exact-matches) (not (null? (cdr exact-matches))))
(not (null? (cdr exact-matches)))) (generate-search-results (list search-key))
(generate-search-results (list search-key))] (let ([match (car exact-matches)])
[else (let-values ([(path tag) (xref-tag->path+anchor x (entry-tag match))])
(let ([match (car exact-matches)]) (send-url/file path #:fragment (uri-encode tag)))))))
(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 (generate-search-results search-keys)
(let ([file (next-search-results-file)] (let ([file (next-search-results-file)]
[search-regexps (map (λ (x) (regexp (regexp-quote x #f))) search-keys)] [search-regexps (map (λ (x) (regexp (regexp-quote x #f))) search-keys)]
[exact-search-regexps (map (λ (x) (regexp (format "^~a$" (regexp-quote x #f)))) search-keys)] [exact-search-regexps
(map (λ (x) (regexp (format "^~a$" (regexp-quote x #f)))) search-keys)]
[search-key-string [search-key-string
(cond (if (null? search-keys)
[(null? search-keys) ""] ""
[else (apply string-append
(apply (car search-keys)
string-append (map (λ (x) (format ", or ~a" x)) (cdr search-keys))))])
(car search-keys)
(map (λ (x) (format ", or ~a" x))
(cdr search-keys)))])])
(let ([x (load-collections-xref)]) (let ([x (load-collections-xref)])
(xref-render (xref-render
x x
@ -78,51 +74,34 @@
(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:
(append (append
(cond (if (method-index-desc? desc)
[(method-index-desc? desc) (list " method of "
(list " method of " ;; This is bad. We need a more abstract way to take a
;; This is bad. We need a more abstract way to take a ;; binding name and tag/source to create a Scheme link.
;; binding name and tag/source to create a Scheme link. (make-element
(make-element "schemesymbol"
"schemesymbol" (list (make-link-element
(list (make-link-element "schemevaluelink"
"schemevaluelink" (list (symbol->string (exported-index-desc-name desc)))
(list (symbol->string (exported-index-desc-name desc))) (method-index-desc-class-tag desc)))))
(method-index-desc-class-tag desc)))))] null)
[else null]) (if (and (exported-index-desc? desc)
(cond (not (null? (exported-index-desc-from-libs desc))))
[(and (exported-index-desc? desc) (cons ", provided from "
(not (null? (exported-index-desc-from-libs desc)))) (cdr (apply append
(cons ", provided from " (map (lambda (lib) (list ", " (scheme:to-element lib)))
(cdr (apply append (exported-index-desc-from-libs desc)))))
(map (lambda (lib) null)))
(list ", "
(scheme:to-element lib)))
(exported-index-desc-from-libs desc)))))]
[else null])))
(define search-results-files (define next-search-results-file
(reverse (let ([n -1] [tmp (find-system-path 'temp-dir)])
(let loop ([n 10]) (lambda ()
(cond (set! n (modulo (add1 n) 10))
[(zero? n) '()] (build-path tmp (format "search-results-~a.html" n)))))
[else
(cons (build-path (find-system-path 'temp-dir)
(format "search-results-~a.html" n))
(loop (- n 1)))]))))
(define (next-search-results-file)
(begin0 (car search-results-files)
(set! search-results-files
(append (cdr search-results-files)
(list (car search-results-files))))))
;; has-match : (listof regexp) -> entry -> boolean ;; has-match : (listof regexp) -> entry -> boolean
(define ((has-match search-regexps) entry) (define ((has-match search-regexps) entry)
(ormap (λ (str) (ormap (λ (str) (ormap (λ (key) (regexp-match key str)) search-regexps))
(ormap
(λ (key) (regexp-match key str))
search-regexps))
(entry-words entry))) (entry-words entry)))
;; limit : exact-positive-integer ;; limit : exact-positive-integer
@ -131,13 +110,12 @@
;; build-itemization : (listof entry) -> (listof <stuff>) ;; build-itemization : (listof entry) -> (listof <stuff>)
(define (build-itemization title entries) (define (build-itemization title entries)
(cond (if (null? entries)
[(null? entries) '()] '()
[else (let ([entries
(let ([entries (sort
(sort entries
entries (λ (x y) (string-ci<=? (entry->sort-key x) (entry->sort-key y))))])
(λ (x y) (string-ci<=? (entry->sort-key x) (entry->sort-key y))))])
(list* (list*
(bold title) (bold title)
(apply itemize (apply itemize
@ -155,17 +133,17 @@
entries))) entries)))
(if (<= (length entries) limit) (if (<= (length entries) limit)
'() '()
(list (make-element "schemeerror" (list (format "Search truncated after ~a hits." limit)))))))])) (list (make-element "schemeerror"
(list (format "Search truncated after ~a hits."
limit)))))))))
(define (limit-length n l) (define (limit-length n l)
(cond (cond [(null? l) '()]
[(null? l) '()] [(zero? n) '()]
[(zero? n) '()] [else (cons (car l) (limit-length (- n 1) (cdr l)))]))
[else (cons (car l) (limit-length (- n 1) (cdr l)))]))
(define (entry->sort-key e) (define (entry->sort-key e)
(let ([words (entry-words e)]) (let ([words (entry-words e)])
(apply string-append (apply string-append
(car words) (car words)
(map (λ (x) (string-append ", " x)) (map (λ (x) (string-append ", " x)) (cdr words)))))
(cdr words)))))