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