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

..

Browse Source 
original commit: 58a60934bb4e73b0fc3e06ed90141c5528592c2f
This commit is contained in:
Robby Findler 2003-04-06 21:03:14 +00:00
parent bb58e25a7a
commit 0cabae7acd
1 changed files with 194 additions and 182 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

376
collects/help/private/search.ss
View File

@ -3,10 +3,17 @@
"docpos.ss" "docpos.ss"
"colldocs.ss" "colldocs.ss"
"path.ss" "path.ss"
(lib "list.ss")) (lib "list.ss")
(lib "contract.ss"))
(provide do-search (provide do-search
doc-collections-changed) doc-collections-changed)
(provide/contract (build-string-finds/finds (string?
boolean?
boolean?
. -> .
(values (listof string?)
(listof (union regexp? string?))))))
(define (html-doc-position x) (define (html-doc-position x)
(or (user-defined-doc-position x) (or (user-defined-doc-position x)
@ -83,8 +90,7 @@
txt-doc-names))) txt-doc-names)))
(set! doc-kinds (append (map (lambda (x) 'html) std-docs) (map (lambda (x) 'text) txt-docs))) (set! doc-kinds (append (map (lambda (x) 'html) std-docs) (map (lambda (x) 'text) txt-docs)))
(with-handlers ([not-break-exn? (with-handlers ([not-break-exn? (lambda (x) (set! doc-collection-date 'none))])
(lambda (x) (set! doc-collection-date 'none))])
(set! doc-collection-date (set! doc-collection-date
(file-or-directory-modify-seconds (file-or-directory-modify-seconds
(collection-path "doc"))))) (collection-path "doc")))))
@ -114,17 +120,17 @@
(define (with-hash-table ht key compute) (define (with-hash-table ht key compute)
(dynamic-wind (dynamic-wind
(lambda () (semaphore-wait ht-lock)) (lambda () (semaphore-wait ht-lock))
(lambda () (lambda ()
(let ([sym (string->symbol key)]) (let ([sym (string->symbol key)])
(hash-table-get (hash-table-get
ht ht
sym sym
(lambda () (lambda ()
(let ([v (compute)]) (let ([v (compute)])
(hash-table-put! ht sym v) (hash-table-put! ht sym v)
v))))) v)))))
(lambda () (semaphore-post ht-lock)))) (lambda () (semaphore-post ht-lock))))
(define html-keywords (make-hash-table)) (define html-keywords (make-hash-table))
(define (load-html-keywords doc) (define (load-html-keywords doc)
@ -133,8 +139,8 @@
doc doc
(lambda () (lambda ()
(with-handlers ([not-break-exn? (lambda (x) null)]) (with-handlers ([not-break-exn? (lambda (x) null)])
(with-input-from-file (build-path doc "keywords") (with-input-from-file (build-path doc "keywords")
read))))) read)))))
(define html-indices (make-hash-table)) (define html-indices (make-hash-table))
(define (load-html-index doc) (define (load-html-index doc)
@ -143,8 +149,8 @@
doc doc
(lambda () (lambda ()
(with-handlers ([not-break-exn? (lambda (x) null)]) (with-handlers ([not-break-exn? (lambda (x) null)])
(with-input-from-file (build-path doc "hdindex") (with-input-from-file (build-path doc "hdindex")
read))))) read)))))
(define (parse-txt-file doc ht handle-one) (define (parse-txt-file doc ht handle-one)
(with-hash-table (with-hash-table
@ -281,170 +287,176 @@
(define max-reached #f) (define max-reached #f)
; do-search : (string ; the search text, unprocessed (define (build-string-finds/finds given-find regexp? exact?)
; num ; 0 = keyword, 1 = keyword+index, 2 = all text (cond
; boolean ; #t if string should be used as a regexp [exact? (values (list given-find)
; boolean ; #t if the string should match exactly (not just "contains") (list given-find))]
; value ; arbitrary key supplied to the "add" functions [regexp? (values (list given-find)
; (-> A) ; called when more than enough are found; must escape (list (regexp given-find)))]
; (string value -> void) ; called to output a document section header (e.g., a manual name) [else (let ([wl (split-words given-find)])
; (symbol value -> void) ; called to output a document-kind section header, 'text or 'html (values wl
; (string string string string (union string #f) value -> void) (map regexp (map non-regexp wl))))]))
; ^ ^ ^ ^ ^- label within page
; ^ ^ ^ ^- path to doc page ; do-search : (string ; the search text, unprocessed
; ^ ^ ^- source doc title ; num ; 0 = keyword, 1 = keyword+index, 2 = all text
; ^ ^- display label ; boolean ; #t if string should be used as a regexp
; ^- found entry's key ; boolean ; #t if the string should match exactly (not just "contains")
; -> ; value ; arbitrary key supplied to the "add" functions
; (union string #f)) ; (-> A) ; called when more than enough are found; must escape
(define (do-search given-find search-level regexp? exact? ckey maxxed-out ; (string value -> void) ; called to output a document section header (e.g., a manual name)
add-doc-section add-kind-section add-choice) ; (symbol value -> void) ; called to output a document-kind section header, 'text or 'html
; When new docs are installed, the directory's modification date changes: ; (string string string string (union string #f) value -> void)
(set! max-reached #f) ; ^ ^ ^ ^ ^- label within page
(unless (eq? doc-collection-date 'none) ; ^ ^ ^ ^- path to doc page
(when (or (not doc-collection-date) ; ^ ^ ^- source doc title
(> (file-or-directory-modify-seconds (collection-path "doc")) ; ^ ^- display label
doc-collection-date)) ; ^- found entry's key
(reset-doc-lists))) ; ->
(let* ([hit-count 0] ; (union string #f))
[string-finds (list given-find)] (define (do-search given-find search-level regexp? exact? ckey maxxed-out
[finds (cond add-doc-section add-kind-section add-choice)
[exact? (list given-find)] ; When new docs are installed, the directory's modification date changes:
[regexp? (list (regexp given-find))] (set! max-reached #f)
[else (let ([wl (split-words given-find)]) (unless (eq? doc-collection-date 'none)
(set! string-finds wl) (when (or (not doc-collection-date)
(map regexp (map non-regexp wl)))])]) (> (file-or-directory-modify-seconds (collection-path "doc"))
(for-each doc-collection-date))
(lambda (doc doc-name doc-kind) (reset-doc-lists)))
(define found-one #f) (let ([hit-count 0])
(define (found kind) (let-values ([(string-finds finds) (build-string-finds/finds given-find regexp? exact?)])
(unless found-one (for-each
(add-doc-section doc-name ckey)) (lambda (doc doc-name doc-kind)
(unless (equal? found-one kind) (define found-one #f)
(set! found-one kind) (define (found kind)
(add-kind-section kind ckey)) (unless found-one
(set! hit-count (add1 hit-count)) (add-doc-section doc-name ckey))
(unless (< hit-count MAX-HIT-COUNT) (unless (equal? found-one kind)
(maxxed-out))) (set! found-one kind)
(add-kind-section kind ckey))
(set! hit-count (add1 hit-count))
(unless (< hit-count MAX-HIT-COUNT)
(maxxed-out)))
; Keyword search
(let ([keys (case doc-kind
[(html) (load-html-keywords doc)]
[(text) (load-txt-keywords doc)]
[else null])]
[add-key-choice (lambda (v)
(found "keyword entries")
(add-choice
(car v) ; key
(cadr v) ; display
(list-ref v 4) ; title
(if (eq? 'text doc-kind)
(apply build-path doc)
(let ([file (list-ref v 2)])
(if (servlet-path? file)
file
(build-path doc file))))
(list-ref v 3) ; label
ckey))])
; Keyword search (unless regexp?
(let ([keys (case doc-kind (for-each
[(html) (load-html-keywords doc)] (lambda (v)
[(text) (load-txt-keywords doc)] (when (string=? given-find (car v))
[else null])] (add-key-choice v)))
[add-key-choice (lambda (v) keys))
(found "keyword entries") (unless (or exact? (null? finds))
(add-choice (for-each
(car v) ; key (lambda (v)
(cadr v) ; display (when (andmap (lambda (find) (regexp-match find (car v))) finds)
(list-ref v 4) ; title (unless (and (not regexp?) (string=? given-find (car v)))
(if (eq? 'text doc-kind) (add-key-choice v))))
(apply build-path doc) keys)))
(let ([file (list-ref v 2)]) ; Index search
(if (servlet-path? file) (unless (< search-level 1)
file (let ([index (case doc-kind
(build-path doc file)))) [(html) (load-html-index doc)]
(list-ref v 3) ; label [(text) (load-txt-index doc)]
ckey))]) [else null])]
[add-index-choice (lambda (name desc)
(unless regexp? (case doc-kind
(for-each [(html)
(lambda (v) (found "index entries")
(when (string=? given-find (car v)) (add-choice
(add-key-choice v))) "" name
keys)) (list-ref desc 2)
(unless (or exact? (null? finds)) (let ([filename (list-ref desc 0)])
(for-each (if (servlet-path? filename)
(lambda (v) filename
(when (andmap (lambda (find) (regexp-match find (car v))) finds) (combine-path/url-path doc filename)))
(unless (and (not regexp?) (string=? given-find (car v))) (list-ref desc 1)
(add-key-choice v)))) ckey)]
keys))) [(text)
; Index search (found "index entries")
(unless (< search-level 1) (add-choice
(let ([index (case doc-kind "" name
[(html) (load-html-index doc)] "indexed content"
[(text) (load-txt-index doc)] (apply build-path doc)
[else null])] desc
[add-index-choice (lambda (name desc) ckey)]))])
(case doc-kind (when index
[(html) (unless regexp?
(found "index entries") (for-each
(add-choice (lambda (v)
"" name (when (string=? given-find (car v))
(list-ref desc 2) (add-index-choice (car v) (cdr v))))
(let ([filename (list-ref desc 0)]) index))
(if (servlet-path? filename) (unless (or exact? (null? finds))
filename (for-each
(combine-path/url-path doc filename))) (lambda (v)
(list-ref desc 1) (when (andmap (lambda (find) (regexp-match find (car v))) finds)
ckey)] (unless (and (not regexp?) (string=? given-find (car v)))
[(text) (add-index-choice (car v) (cdr v)))))
(found "index entries") index)))))
(add-choice ; Content Search
"" name (unless (or (< search-level 2) exact? (null? finds))
"indexed content" (let ([files (case doc-kind
(apply build-path doc) [(html) (with-handlers ([not-break-exn? (lambda (x) null)])
desc (map (lambda (x) (build-path doc x))
ckey)]))]) (filter
(when index (lambda (x) (file-exists? (build-path doc x)))
(unless regexp? (directory-list doc))))]
(for-each [(text) (list (apply build-path doc))]
(lambda (v) [else null])])
(when (string=? given-find (car v)) (for-each
(add-index-choice (car v) (cdr v)))) (lambda (f)
index)) (with-handlers ([not-break-exn? (lambda (x) #f)])
(unless (or exact? (null? finds)) (with-input-from-file f
(for-each (lambda ()
(lambda (v) (let loop ()
(when (andmap (lambda (find) (regexp-match find (car v))) finds) (let ([pos (file-position (current-input-port))]
(unless (and (not regexp?) (string=? given-find (car v))) [r (read-line)])
(add-index-choice (car v) (cdr v))))) (unless (eof-object? r)
index))))) (let ([m (andmap (lambda (find) (regexp-match find r)) finds)])
; Content Search (when m
(unless (or (< search-level 2) exact? (null? finds)) (found "text")
(let ([files (case doc-kind (add-choice (car m)
[(html) (with-handlers ([not-break-exn? (lambda (x) null)]) ; Strip leading space and clean HTML
(map (lambda (x) (build-path doc x)) (regexp-replace
(filter "^ [ ]*"
(lambda (x) (file-exists? (build-path doc x))) (if (eq? doc-kind 'html)
(directory-list doc))))] (clean-html r)
[(text) (list (apply build-path doc))] r)
[else null])]) "")
(for-each "content"
(lambda (f) f
(with-handlers ([not-break-exn? (lambda (x) #f)]) (if (eq? doc-kind 'text) pos "NO TAG")
(with-input-from-file f ckey)))
(lambda () (loop))))))))
(let loop () files))))
(let ([pos (file-position (current-input-port))] docs doc-names doc-kinds)
[r (read-line)]) (if (= 0 hit-count)
(unless (eof-object? r) (format (string-constant plt:hd:nothing-found-for)
(let ([m (andmap (lambda (find) (regexp-match find r)) finds)]) (if (null? string-finds)
(when m ""
(found "text") (apply
(add-choice (car m) string-append
; Strip leading space and clean HTML (cons (format "\"~a\"" (car string-finds))
(regexp-replace (map (lambda (i) (format " ~a \"~a\"" (string-constant plt:hd:and) i))
"^ [ ]*" (cdr string-finds))))))
(if (eq? doc-kind 'html) #f)))))
(clean-html r)
r)
"")
"content"
f
(if (eq? doc-kind 'text) pos "NO TAG")
ckey)))
(loop))))))))
files))))
docs doc-names doc-kinds)
(if (= 0 hit-count)
(format (string-constant plt:hd:nothing-found-for)
(apply
string-append
(cons (format "\"~a\"" (car string-finds))
(map (lambda (i) (format " ~a \"~a\"" (string-constant plt:hd:and) i))
(cdr string-finds)))))
#f))))