v201 changes
original commit: 4928ab22adbeffbca64d394176af6da4e3002212
This commit is contained in:
Paul Steckler
parent
eced374756
commit
d54711c88b
|
|
@ -1,282 +1,294 @@
|
|||
|
||||
(module search mzscheme
|
||||
(require (lib "string-constant.ss" "string-constants")
|
||||
(lib "unitsig.ss")
|
||||
"sig.ss"
|
||||
"../help-sig.ss"
|
||||
"docpos.ss"
|
||||
"colldocs.ss"
|
||||
(lib "list.ss"))
|
||||
(lib "list.ss")
|
||||
(lib "util.ss" "doc" "help" "servlets" "private")
|
||||
"../server.ss"
|
||||
"../browser.ss")
|
||||
|
||||
(provide search@)
|
||||
(provide do-search
|
||||
doc-collections-changed
|
||||
search-for-docs)
|
||||
|
||||
(define search@
|
||||
(unit/sig search^
|
||||
(import help:doc-position^)
|
||||
; hd-cookie string sym sym any -> void
|
||||
; shows search result in default browser
|
||||
(define (search-for-docs cookie search-string search-type match-type lucky?)
|
||||
(let* ([port (hd-cookie->port cookie)]
|
||||
[url (format
|
||||
(string-append "http://127.0.0.1:~a/servlets/index.ss?"
|
||||
"search-string=~a&"
|
||||
"search-type=~a&"
|
||||
"match-type=~a&"
|
||||
"lucky=~a")
|
||||
port (hexify-string search-string) search-type match-type
|
||||
(if lucky? "true" "false"))])
|
||||
(help-desk-navigate url)))
|
||||
|
||||
(define (html-doc-position x)
|
||||
(or (user-defined-doc-position x)
|
||||
(standard-html-doc-position x)))
|
||||
|
||||
; These are set by reset-doc-lists:
|
||||
; docs, doc-names and doc-kinds are parallel lists. doc-kinds
|
||||
; distinguishes between the two variants of docs.
|
||||
; docs : (list-of (union string (list string string)))
|
||||
(define docs null)
|
||||
; doc-names : (list-of string)
|
||||
(define doc-names null)
|
||||
; doc-kinds : (list-of symbol)
|
||||
(define doc-kinds null)
|
||||
; doc-collection-date : (union #f number 'none)
|
||||
(define doc-collection-date #f)
|
||||
|
||||
(define (html-doc-position x)
|
||||
(or (user-defined-doc-position x)
|
||||
(standard-html-doc-position x)))
|
||||
(define re:title (regexp "<[tT][iI][tT][lL][eE]>(.*)</[tT][iI][tT][lL][eE]>"))
|
||||
|
||||
; These are set by reset-doc-lists:
|
||||
; docs, doc-names and doc-kinds are parallel lists. doc-kinds
|
||||
; distinguishes between the two variants of docs.
|
||||
; docs : (list-of (union string (list string string)))
|
||||
(define docs null)
|
||||
; doc-names : (list-of string)
|
||||
(define doc-names null)
|
||||
; doc-kinds : (list-of symbol)
|
||||
(define doc-kinds null)
|
||||
; doc-collection-date : ??
|
||||
(define doc-collection-date #f)
|
||||
; get-std-doc-title : string -> string
|
||||
; gets the standard title of the documentation, from the
|
||||
; known docs list.
|
||||
(define (get-std-doc-title path doc)
|
||||
(let ([a (assoc doc known-docs)])
|
||||
(if a
|
||||
(cdr a)
|
||||
(let ([index-file (build-path path doc "index.htm")])
|
||||
(if (file-exists? index-file)
|
||||
(call-with-input-file index-file
|
||||
(lambda (port)
|
||||
(let loop ()
|
||||
(let ([l (read-line port)])
|
||||
(cond
|
||||
[(eof-object? l)
|
||||
doc]
|
||||
[(regexp-match re:title l)
|
||||
=>
|
||||
(lambda (m)
|
||||
(apply
|
||||
string
|
||||
(map (lambda (x) (if (char-whitespace? x) #\space x))
|
||||
(string->list (cadr m)))))]
|
||||
[else (loop)])))))
|
||||
doc)))))
|
||||
|
||||
(define (reset-doc-lists)
|
||||
; Locate standard HTML documentation
|
||||
(define-values (std-docs std-doc-names)
|
||||
(let* ([path (with-handlers ([not-break-exn? (lambda (x) #f)])
|
||||
(collection-path "doc"))])
|
||||
(if path
|
||||
(let* ([doc-collections (directory-list path)]
|
||||
[docs (map (lambda (x) (build-path path x)) doc-collections)]
|
||||
[doc-names (map (lambda (x) (get-std-doc-title path x)) doc-collections)])
|
||||
; Order the standard docs:
|
||||
(let ([ordered (quicksort
|
||||
(map list docs doc-collections doc-names)
|
||||
(lambda (a b) ; html-doc-position expects collection name
|
||||
(< (html-doc-position (cadr a))
|
||||
(html-doc-position (cadr b)))))])
|
||||
(values (map car ordered) (map caddr ordered)))) ; here we want the std title
|
||||
(values null null))))
|
||||
|
||||
; Check collections for doc.txt files:
|
||||
(define-values (txt-docs txt-doc-names) (colldocs))
|
||||
|
||||
(set! docs (append std-docs txt-docs))
|
||||
(set! doc-names (append
|
||||
std-doc-names
|
||||
(map (lambda (s) (format "the ~a collection" s))
|
||||
txt-doc-names)))
|
||||
(set! doc-kinds (append (map (lambda (x) 'html) std-docs) (map (lambda (x) 'text) txt-docs)))
|
||||
|
||||
(with-handlers ([not-break-exn?
|
||||
(lambda (x) (set! doc-collection-date 'none))])
|
||||
(set! doc-collection-date
|
||||
(file-or-directory-modify-seconds
|
||||
(collection-path "doc")))))
|
||||
|
||||
(define MAX-HIT-COUNT 300)
|
||||
|
||||
(define (clean-html s)
|
||||
(regexp-replace*
|
||||
"&[^;]*;"
|
||||
(regexp-replace*
|
||||
"<[^>]*>"
|
||||
(regexp-replace*
|
||||
"&"
|
||||
(regexp-replace*
|
||||
">"
|
||||
(regexp-replace*
|
||||
"<"
|
||||
s
|
||||
"<")
|
||||
">")
|
||||
"\\&")
|
||||
"")
|
||||
""))
|
||||
|
||||
; One lock for all hash table operations is good enough
|
||||
(define ht-lock (make-semaphore 1))
|
||||
|
||||
(define (with-hash-table ht key compute)
|
||||
(dynamic-wind
|
||||
(lambda () (semaphore-wait ht-lock))
|
||||
(lambda ()
|
||||
(let ([sym (string->symbol key)])
|
||||
(hash-table-get
|
||||
ht
|
||||
sym
|
||||
(lambda ()
|
||||
(let ([v (compute)])
|
||||
(hash-table-put! ht sym v)
|
||||
v)))))
|
||||
(lambda () (semaphore-post ht-lock))))
|
||||
|
||||
(define html-keywords (make-hash-table))
|
||||
(define (load-html-keywords doc)
|
||||
(with-hash-table
|
||||
html-keywords
|
||||
doc
|
||||
(lambda ()
|
||||
(with-handlers ([not-break-exn? (lambda (x) null)])
|
||||
(with-input-from-file (build-path doc "keywords")
|
||||
read)))))
|
||||
|
||||
(define re:title (regexp "<[tT][iI][tT][lL][eE]>(.*)</[tT][iI][tT][lL][eE]>"))
|
||||
(define html-indices (make-hash-table))
|
||||
(define (load-html-index doc)
|
||||
(with-hash-table
|
||||
html-indices
|
||||
doc
|
||||
(lambda ()
|
||||
(with-handlers ([not-break-exn? (lambda (x) null)])
|
||||
(with-input-from-file (build-path doc "hdindex")
|
||||
read)))))
|
||||
|
||||
; get-std-doc-title : string -> string
|
||||
; gets the standard title of the documentation, from the
|
||||
; known docs list.
|
||||
(define (get-std-doc-title path doc)
|
||||
(let ([a (assoc doc known-docs)])
|
||||
(if a
|
||||
(cdr a)
|
||||
(let ([index-file (build-path path doc "index.htm")])
|
||||
(if (file-exists? index-file)
|
||||
(call-with-input-file index-file
|
||||
(lambda (port)
|
||||
(let loop ()
|
||||
(let ([l (read-line port)])
|
||||
(cond
|
||||
[(eof-object? l)
|
||||
doc]
|
||||
[(regexp-match re:title l)
|
||||
=>
|
||||
(lambda (m)
|
||||
(apply
|
||||
string
|
||||
(map (lambda (x) (if (char-whitespace? x) #\space x))
|
||||
(string->list (cadr m)))))]
|
||||
[else (loop)])))))
|
||||
doc)))))
|
||||
(define (parse-txt-file doc ht handle-one)
|
||||
(with-hash-table
|
||||
ht
|
||||
doc
|
||||
(lambda ()
|
||||
(with-handlers
|
||||
([not-break-exn? (lambda (x) null)])
|
||||
(with-input-from-file doc
|
||||
(lambda ()
|
||||
(let loop ([start 0])
|
||||
(let* ([r (read-line (current-input-port) 'any)]
|
||||
[next (if (eof-object? r)
|
||||
start
|
||||
(+ start (string-length r) 1))])
|
||||
(cond
|
||||
[(eof-object? r) null]
|
||||
[(handle-one r start) => (lambda (vs) (append vs (loop next)))]
|
||||
[else (loop next)])))))))))
|
||||
|
||||
(define re:keyword-line (regexp "^>"))
|
||||
(define text-keywords (make-hash-table))
|
||||
(define (load-txt-keywords doc)
|
||||
(parse-txt-file
|
||||
(apply build-path doc)
|
||||
text-keywords
|
||||
(lambda (r start)
|
||||
(cond
|
||||
[(regexp-match re:keyword-line r)
|
||||
(let* ([p (open-input-string (substring r 1 (string-length r)))]
|
||||
[entry (parameterize ([read-accept-bar-quote #f])
|
||||
(read p))]
|
||||
[key (let loop ([entry entry])
|
||||
(cond
|
||||
[(symbol? entry) entry]
|
||||
[(pair? entry) (if (eq? (car entry) 'quote)
|
||||
(loop (cadr entry))
|
||||
(loop (car entry)))]
|
||||
[else (error "bad entry")]))]
|
||||
[content (if (symbol? entry)
|
||||
(with-handlers ([not-break-exn? (lambda (x) #f)])
|
||||
(let ([s (read p)])
|
||||
(if (eq? s '::)
|
||||
(read p)
|
||||
#f)))
|
||||
#f)])
|
||||
(list
|
||||
; Make the keyword entry:
|
||||
(list (symbol->string key) ; the keyword name
|
||||
(let ([p (open-output-string)])
|
||||
(if content
|
||||
(display content p)
|
||||
(if (and (pair? entry)
|
||||
(eq? (car entry) 'quote))
|
||||
(fprintf p "'~s" (cadr entry))
|
||||
(display entry p)))
|
||||
(get-output-string p)) ; the text to display
|
||||
(cadr doc) ; file
|
||||
start ; label (a position in this case)
|
||||
"doc.txt")))] ; title
|
||||
[else #f]))))
|
||||
|
||||
(define re:index-line (regexp "_([^_]*)_(.*)"))
|
||||
(define text-indices (make-hash-table))
|
||||
(define (load-txt-index doc)
|
||||
(parse-txt-file
|
||||
(apply build-path doc)
|
||||
text-indices
|
||||
(lambda (r start)
|
||||
(cond
|
||||
[(regexp-match re:index-line r)
|
||||
=> (lambda (m)
|
||||
(let loop ([m m])
|
||||
(let ([s (cadr m)])
|
||||
(cons
|
||||
; Make an index entry:
|
||||
(cons s start)
|
||||
(let ([m (regexp-match re:index-line (caddr m))])
|
||||
(if m
|
||||
(loop m)
|
||||
null))))))]
|
||||
[else #f]))))
|
||||
|
||||
(define re:splitter (regexp "^ *([^ ]+)(.*)"))
|
||||
(define (split-words s)
|
||||
(let ([m (regexp-match re:splitter s)])
|
||||
(if m
|
||||
(cons (cadr m)
|
||||
(split-words (caddr m)))
|
||||
null)))
|
||||
|
||||
(define (reset-doc-lists)
|
||||
; Locate standard HTML documentation
|
||||
(define-values (std-docs std-doc-names)
|
||||
(let* ([path (with-handlers ([not-break-exn? (lambda (x) #f)])
|
||||
(collection-path "doc"))])
|
||||
(if path
|
||||
(let* ([doc-collections (directory-list path)]
|
||||
[docs (map (lambda (x) (build-path path x)) doc-collections)]
|
||||
[doc-names (map (lambda (x) (get-std-doc-title path x)) doc-collections)])
|
||||
; Order the standard docs:
|
||||
(let ([ordered (quicksort
|
||||
(map cons docs doc-names)
|
||||
(lambda (a b)
|
||||
(< (html-doc-position (cdr a))
|
||||
(html-doc-position (cdr b)))))])
|
||||
(values (map car ordered) (map cdr ordered))))
|
||||
(values null null))))
|
||||
|
||||
; Check collections for doc.txt files:
|
||||
(define-values (txt-docs txt-doc-names) (colldocs))
|
||||
|
||||
(set! docs (append std-docs txt-docs))
|
||||
(set! doc-names (append
|
||||
std-doc-names
|
||||
(map (lambda (s) (format "the ~a collection" s))
|
||||
txt-doc-names)))
|
||||
(set! doc-kinds (append (map (lambda (x) 'html) std-docs) (map (lambda (x) 'text) txt-docs)))
|
||||
|
||||
(with-handlers ([not-break-exn?
|
||||
(lambda (x) (set! doc-collection-date 'none))])
|
||||
(set! doc-collection-date
|
||||
(file-or-directory-modify-seconds
|
||||
(collection-path "doc")))))
|
||||
(define (non-regexp s)
|
||||
(list->string
|
||||
(apply
|
||||
append
|
||||
(map
|
||||
(lambda (c)
|
||||
(cond
|
||||
[(memq c '(#\$ #\| #\\ #\[ #\] #\. #\* #\? #\+ #\( #\) #\^))
|
||||
(list #\\ c)]
|
||||
[(char-alphabetic? c)
|
||||
(list #\[ (char-upcase c) (char-downcase c) #\])]
|
||||
[else (list c)]))
|
||||
(string->list s)))))
|
||||
|
||||
(define MAX-HIT-COUNT 300)
|
||||
(define (doc-collections-changed)
|
||||
(set! doc-collection-date #f)
|
||||
(reset-doc-positions!))
|
||||
|
||||
(define (clean-html s)
|
||||
(regexp-replace*
|
||||
"&[^;]*;"
|
||||
(regexp-replace*
|
||||
"<[^>]*>"
|
||||
(regexp-replace*
|
||||
"&"
|
||||
(regexp-replace*
|
||||
">"
|
||||
(regexp-replace*
|
||||
"<"
|
||||
s
|
||||
"<")
|
||||
">")
|
||||
"\\&")
|
||||
"")
|
||||
""))
|
||||
(define re:url-dir (regexp "^([^/]*)/(.*)$"))
|
||||
(define (combine-path/url-path path url-path)
|
||||
(let loop ([path path]
|
||||
[url-path url-path])
|
||||
(cond
|
||||
[(regexp-match re:url-dir url-path)
|
||||
=>
|
||||
(lambda (m)
|
||||
(let* ([url-dir (cadr m)]
|
||||
[rest (caddr m)]
|
||||
[dir
|
||||
(cond
|
||||
[(string=? ".." url-dir) 'up]
|
||||
[(string=? "." url-dir) 'same]
|
||||
[(string=? "" url-dir) 'same]
|
||||
[else url-dir])])
|
||||
(loop (build-path path dir)
|
||||
rest)))]
|
||||
[else (build-path path url-path)])))
|
||||
|
||||
; One lock for all hash table operations is good enough
|
||||
(define ht-lock (make-semaphore 1))
|
||||
|
||||
(define (with-hash-table ht key compute)
|
||||
(dynamic-wind
|
||||
(lambda () (semaphore-wait ht-lock))
|
||||
(lambda ()
|
||||
(let ([sym (string->symbol key)])
|
||||
(hash-table-get
|
||||
ht
|
||||
sym
|
||||
(lambda ()
|
||||
(let ([v (compute)])
|
||||
(hash-table-put! ht sym v)
|
||||
v)))))
|
||||
(lambda () (semaphore-post ht-lock))))
|
||||
|
||||
(define html-keywords (make-hash-table))
|
||||
(define (load-html-keywords doc)
|
||||
(with-hash-table
|
||||
html-keywords
|
||||
doc
|
||||
(lambda ()
|
||||
(with-handlers ([not-break-exn? (lambda (x) null)])
|
||||
(with-input-from-file (build-path doc "keywords")
|
||||
read)))))
|
||||
|
||||
(define html-indices (make-hash-table))
|
||||
(define (load-html-index doc)
|
||||
(with-hash-table
|
||||
html-indices
|
||||
doc
|
||||
(lambda ()
|
||||
(with-handlers ([not-break-exn? (lambda (x) null)])
|
||||
(with-input-from-file (build-path doc "hdindex")
|
||||
read)))))
|
||||
|
||||
(define (parse-txt-file doc ht handle-one)
|
||||
(with-hash-table
|
||||
ht
|
||||
doc
|
||||
(lambda ()
|
||||
(with-handlers ([not-break-exn? (lambda (x) null)])
|
||||
(with-input-from-file doc
|
||||
(lambda ()
|
||||
(let loop ([start 0])
|
||||
(let* ([r (read-line (current-input-port) 'any)]
|
||||
[next (if (eof-object? r)
|
||||
start
|
||||
(+ start (string-length r) 1))])
|
||||
(cond
|
||||
[(eof-object? r) null]
|
||||
[(handle-one r start) => (lambda (vs) (append vs (loop next)))]
|
||||
[else (loop next)])))))))))
|
||||
|
||||
(define re:keyword-line (regexp "^>"))
|
||||
(define text-keywords (make-hash-table))
|
||||
(define (load-txt-keywords doc)
|
||||
(parse-txt-file
|
||||
(apply build-path doc)
|
||||
text-keywords
|
||||
(lambda (r start)
|
||||
(cond
|
||||
[(regexp-match re:keyword-line r)
|
||||
(let* ([p (open-input-string (substring r 1 (string-length r)))]
|
||||
[entry (parameterize ([read-accept-bar-quote #f])
|
||||
(read p))]
|
||||
[key (let loop ([entry entry])
|
||||
(cond
|
||||
[(symbol? entry) entry]
|
||||
[(pair? entry) (if (eq? (car entry) 'quote)
|
||||
(loop (cadr entry))
|
||||
(loop (car entry)))]
|
||||
[else (error "bad entry")]))]
|
||||
[content (if (symbol? entry)
|
||||
(with-handlers ([not-break-exn? (lambda (x) #f)])
|
||||
(let ([s (read p)])
|
||||
(if (eq? s '::)
|
||||
(read p)
|
||||
#f)))
|
||||
#f)])
|
||||
(list
|
||||
; Make the keyword entry:
|
||||
(list (symbol->string key) ; the keyword name
|
||||
(let ([p (open-output-string)])
|
||||
(if content
|
||||
(display content p)
|
||||
(if (and (pair? entry)
|
||||
(eq? (car entry) 'quote))
|
||||
(fprintf p "'~s" (cadr entry))
|
||||
(display entry p)))
|
||||
(get-output-string p)) ; the text to display
|
||||
(cadr doc) ; file
|
||||
start ; label (a position in this case)
|
||||
"doc.txt")))] ; title
|
||||
[else #f]))))
|
||||
|
||||
(define re:index-line (regexp "_([^_]*)_(.*)"))
|
||||
(define text-indices (make-hash-table))
|
||||
(define (load-txt-index doc)
|
||||
(parse-txt-file
|
||||
(apply build-path doc)
|
||||
text-indices
|
||||
(lambda (r start)
|
||||
(cond
|
||||
[(regexp-match re:index-line r)
|
||||
=> (lambda (m)
|
||||
(let loop ([m m])
|
||||
(let ([s (cadr m)])
|
||||
(cons
|
||||
; Make an index entry:
|
||||
(cons s start)
|
||||
(let ([m (regexp-match re:index-line (caddr m))])
|
||||
(if m
|
||||
(loop m)
|
||||
null))))))]
|
||||
[else #f]))))
|
||||
|
||||
(define re:splitter (regexp "^ *([^ ]+)(.*)"))
|
||||
(define (split-words s)
|
||||
(let ([m (regexp-match re:splitter s)])
|
||||
(if m
|
||||
(cons (cadr m)
|
||||
(split-words (caddr m)))
|
||||
null)))
|
||||
|
||||
(define (non-regexp s)
|
||||
(list->string
|
||||
(apply
|
||||
append
|
||||
(map
|
||||
(lambda (c)
|
||||
(cond
|
||||
[(memq c '(#\$ #\| #\\ #\[ #\] #\. #\* #\? #\+ #\( #\) #\^))
|
||||
(list #\\ c)]
|
||||
[(char-alphabetic? c)
|
||||
(list #\[ (char-upcase c) (char-downcase c) #\])]
|
||||
[else (list c)]))
|
||||
(string->list s)))))
|
||||
|
||||
(define (doc-collections-changed)
|
||||
(set! doc-collection-date #f))
|
||||
|
||||
(define re:url-dir (regexp "^([^/]*)/(.*)$"))
|
||||
(define (combine-path/url-path path url-path)
|
||||
(let loop ([path path]
|
||||
[url-path url-path])
|
||||
(cond
|
||||
[(regexp-match re:url-dir url-path)
|
||||
=>
|
||||
(lambda (m)
|
||||
(let* ([url-dir (cadr m)]
|
||||
[rest (caddr m)]
|
||||
[dir
|
||||
(cond
|
||||
[(string=? ".." url-dir) 'up]
|
||||
[(string=? "." url-dir) 'same]
|
||||
[(string=? "" url-dir) 'same]
|
||||
[else url-dir])])
|
||||
(loop (build-path path dir)
|
||||
rest)))]
|
||||
[else (build-path path url-path)])))
|
||||
|
||||
; do-search : (string ; the search text, unprocessed
|
||||
; do-search : (string ; the search text, unprocessed
|
||||
; num ; 0 = keyword, 1 = keyword+index, 2 = all text
|
||||
; boolean ; #t if string should be used as a regexp
|
||||
; boolean ; #t if the string should match exactly (not just "contains")
|
||||
|
|
@ -431,9 +443,8 @@
|
|||
(format (string-constant nothing-found-for)
|
||||
(apply
|
||||
string-append
|
||||
(append
|
||||
(cons (format "\"~a\"" (car string-finds))
|
||||
(map (lambda (i) (format " ~a \"~a\"" (string-constant and) i))
|
||||
(cdr string-finds)))
|
||||
(list "."))))])
|
||||
#f))))))
|
||||
(cons (format "\"~a\"" (car string-finds))
|
||||
(map (lambda (i) (format " ~a \"~a\"" (string-constant and) i))
|
||||
(cdr string-finds)))))])
|
||||
#f))))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user