no message
original commit: fdd4883bef661bfd92969bc7a825ba9f31f6625c
This commit is contained in:
Robby Findler
parent
85317e5400
commit
9fd3522c22
|
|
@ -1,433 +1,442 @@
|
||||||
(unit/sig help:search^
|
|
||||||
(import help:doc-position^
|
|
||||||
mzlib:function^)
|
|
||||||
|
|
||||||
; Define an order for the documentation:
|
(module search mzscheme
|
||||||
; and the names of the standard documentation
|
(require (lib "unitsig.ss")
|
||||||
(define-values (standard-html-doc-position known-manuals)
|
"sig.ss"
|
||||||
(let ([pr (require-library "docpos.ss" "help")])
|
"../help-sig.ss"
|
||||||
(values (car pr) (cdr pr))))
|
(lib "list.ss"))
|
||||||
|
|
||||||
(define (html-doc-position x)
|
(provide search@)
|
||||||
(or (user-defined-doc-position x)
|
|
||||||
(standard-html-doc-position x)))
|
|
||||||
|
|
||||||
; These are set by reset-doc-lists:
|
(define search@
|
||||||
;; docs, doc-names and doc-kinds are parallel lists. doc-kinds
|
(unit/sig search^
|
||||||
;; distinguishes between the two variants of docs.
|
(import help:doc-position^)
|
||||||
;; 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)
|
|
||||||
|
|
||||||
(define colldocs (require-library "colldocs.ss" "help"))
|
; Define an order for the documentation:
|
||||||
|
; and the names of the standard documentation
|
||||||
|
(define-values (standard-html-doc-position known-manuals)
|
||||||
|
(let ([pr (require-library "docpos.ss" "help")])
|
||||||
|
(values (car pr) (cdr pr))))
|
||||||
|
|
||||||
(define re:title (regexp "<[tT][iI][tT][lL][eE]>(.*)</[tT][iI][tT][lL][eE]>"))
|
(define (html-doc-position x)
|
||||||
|
(or (user-defined-doc-position x)
|
||||||
|
(standard-html-doc-position x)))
|
||||||
|
|
||||||
;; get-std-doc-title : string -> string
|
; These are set by reset-doc-lists:
|
||||||
;; gets the standard title of the documentation, from the
|
; docs, doc-names and doc-kinds are parallel lists. doc-kinds
|
||||||
;; known docs list.
|
; distinguishes between the two variants of docs.
|
||||||
(define (get-std-doc-title path doc)
|
; docs : (list-of (union string (list string string)))
|
||||||
(let ([a (assoc doc known-manuals)])
|
(define docs null)
|
||||||
(if a
|
; doc-names : (list-of string)
|
||||||
(cdr a)
|
(define doc-names null)
|
||||||
(let ([index-file (build-path path doc "index.htm")])
|
; doc-kinds : (list-of symbol)
|
||||||
(if (file-exists? index-file)
|
(define doc-kinds null)
|
||||||
(call-with-input-file index-file
|
; doc-collection-date : ??
|
||||||
(lambda (port)
|
(define doc-collection-date #f)
|
||||||
(let loop ()
|
|
||||||
(let ([l (read-line port)])
|
(define colldocs (require-library "colldocs.ss" "help"))
|
||||||
(cond
|
|
||||||
[(eof-object? l)
|
(define re:title (regexp "<[tT][iI][tT][lL][eE]>(.*)</[tT][iI][tT][lL][eE]>"))
|
||||||
doc]
|
|
||||||
[(regexp-match re:title l)
|
; get-std-doc-title : string -> string
|
||||||
=>
|
; gets the standard title of the documentation, from the
|
||||||
(lambda (m)
|
; known docs list.
|
||||||
(apply
|
(define (get-std-doc-title path doc)
|
||||||
string
|
(let ([a (assoc doc known-manuals)])
|
||||||
(map (lambda (x) (if (char-whitespace? x) #\space x))
|
(if a
|
||||||
(string->list (cadr m)))))]
|
(cdr a)
|
||||||
[else (loop)])))))
|
(let ([index-file (build-path path doc "index.htm")])
|
||||||
doc)))))
|
(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)
|
(define (reset-doc-lists)
|
||||||
; Locate standard HTML documentation
|
; Locate standard HTML documentation
|
||||||
(define-values (std-docs std-doc-names)
|
(define-values (std-docs std-doc-names)
|
||||||
(let* ([path (with-handlers ([void (lambda (x) #f)])
|
(let* ([path (with-handlers ([void (lambda (x) #f)])
|
||||||
(collection-path "doc"))])
|
(collection-path "doc"))])
|
||||||
(if path
|
(if path
|
||||||
(let* ([doc-collections (directory-list path)]
|
(let* ([doc-collections (directory-list path)]
|
||||||
[docs (map (lambda (x) (build-path path x)) doc-collections)]
|
[docs (map (lambda (x) (build-path path x)) doc-collections)]
|
||||||
[doc-names (map (lambda (x) (get-std-doc-title path x)) doc-collections)])
|
[doc-names (map (lambda (x) (get-std-doc-title path x)) doc-collections)])
|
||||||
;; Order the standard docs:
|
; Order the standard docs:
|
||||||
(let ([ordered (quicksort
|
(let ([ordered (quicksort
|
||||||
(map cons docs doc-names)
|
(map cons docs doc-names)
|
||||||
(lambda (a b)
|
(lambda (a b)
|
||||||
(< (html-doc-position (cdr a))
|
(< (html-doc-position (cdr a))
|
||||||
(html-doc-position (cdr b)))))])
|
(html-doc-position (cdr b)))))])
|
||||||
(values (map car ordered) (map cdr ordered))))
|
(values (map car ordered) (map cdr ordered))))
|
||||||
(values null null))))
|
(values null null))))
|
||||||
|
|
||||||
; Check collections for doc.txt files:
|
; Check collections for doc.txt files:
|
||||||
(define-values (txt-docs txt-doc-names)
|
(define-values (txt-docs txt-doc-names)
|
||||||
(colldocs quicksort))
|
(colldocs quicksort))
|
||||||
|
|
||||||
(set! docs (append std-docs txt-docs))
|
(set! docs (append std-docs txt-docs))
|
||||||
(set! doc-names (append
|
(set! doc-names (append
|
||||||
std-doc-names
|
std-doc-names
|
||||||
(map (lambda (s) (format "the ~a collection" s))
|
(map (lambda (s) (format "the ~a collection" s))
|
||||||
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 ([void (lambda (x)
|
(with-handlers ([void (lambda (x)
|
||||||
(set! doc-collection-date 'none))])
|
(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")))))
|
||||||
|
|
||||||
(define MAX-HIT-COUNT 300)
|
(define MAX-HIT-COUNT 300)
|
||||||
|
|
||||||
(define (clean-html s)
|
(define (clean-html s)
|
||||||
(regexp-replace*
|
(regexp-replace*
|
||||||
"&[^;]*;"
|
"&[^;]*;"
|
||||||
(regexp-replace*
|
(regexp-replace*
|
||||||
"<[^>]*>"
|
"<[^>]*>"
|
||||||
(regexp-replace*
|
(regexp-replace*
|
||||||
"&"
|
"&"
|
||||||
(regexp-replace*
|
(regexp-replace*
|
||||||
">"
|
">"
|
||||||
(regexp-replace*
|
(regexp-replace*
|
||||||
"<"
|
"<"
|
||||||
s
|
s
|
||||||
"<")
|
"<")
|
||||||
">")
|
">")
|
||||||
"\\&")
|
"\\&")
|
||||||
"")
|
"")
|
||||||
""))
|
""))
|
||||||
|
|
||||||
(define not-break? (lambda (x) (not (exn:misc:user-break? x))))
|
(define not-break? (lambda (x) (not (exn:misc:user-break? x))))
|
||||||
|
|
||||||
; One lock for all hash table operations is good enough
|
; One lock for all hash table operations is good enough
|
||||||
(define ht-lock (make-semaphore 1))
|
(define ht-lock (make-semaphore 1))
|
||||||
|
|
||||||
(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)
|
||||||
(with-hash-table
|
(with-hash-table
|
||||||
html-keywords
|
html-keywords
|
||||||
doc
|
doc
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(with-handlers ([not-break? (lambda (x) null)])
|
(with-handlers ([not-break? (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)
|
||||||
(with-hash-table
|
(with-hash-table
|
||||||
html-indices
|
html-indices
|
||||||
doc
|
doc
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(with-handlers ([not-break? (lambda (x) null)])
|
(with-handlers ([not-break? (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
|
||||||
ht
|
ht
|
||||||
doc
|
doc
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(with-handlers ([not-break? (lambda (x) null)])
|
(with-handlers ([not-break? (lambda (x) null)])
|
||||||
(with-input-from-file doc
|
(with-input-from-file doc
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(let loop ([start 0])
|
(let loop ([start 0])
|
||||||
(let* ([r (read-line (current-input-port) 'any)]
|
(let* ([r (read-line (current-input-port) 'any)]
|
||||||
[next (if (eof-object? r)
|
[next (if (eof-object? r)
|
||||||
start
|
start
|
||||||
(+ start (string-length r) 1))])
|
(+ start (string-length r) 1))])
|
||||||
(cond
|
(cond
|
||||||
[(eof-object? r) null]
|
[(eof-object? r) null]
|
||||||
[(handle-one r start) => (lambda (vs) (append vs (loop next)))]
|
[(handle-one r start) => (lambda (vs) (append vs (loop next)))]
|
||||||
[else (loop next)])))))))))
|
[else (loop next)])))))))))
|
||||||
|
|
||||||
(define re:keyword-line (regexp "^>"))
|
(define re:keyword-line (regexp "^>"))
|
||||||
(define text-keywords (make-hash-table))
|
(define text-keywords (make-hash-table))
|
||||||
(define (load-txt-keywords doc)
|
(define (load-txt-keywords doc)
|
||||||
(parse-txt-file
|
(parse-txt-file
|
||||||
(apply build-path doc)
|
(apply build-path doc)
|
||||||
text-keywords
|
text-keywords
|
||||||
(lambda (r start)
|
(lambda (r start)
|
||||||
(cond
|
(cond
|
||||||
[(regexp-match re:keyword-line r)
|
[(regexp-match re:keyword-line r)
|
||||||
(let* ([p (open-input-string (substring r 1 (string-length r)))]
|
(let* ([p (open-input-string (substring r 1 (string-length r)))]
|
||||||
[entry (parameterize ([read-accept-bar-quote #f])
|
[entry (parameterize ([read-accept-bar-quote #f])
|
||||||
(read p))]
|
(read p))]
|
||||||
[key (let loop ([entry entry])
|
[key (let loop ([entry entry])
|
||||||
(cond
|
(cond
|
||||||
[(symbol? entry) entry]
|
[(symbol? entry) entry]
|
||||||
[(pair? entry) (if (eq? (car entry) 'quote)
|
[(pair? entry) (if (eq? (car entry) 'quote)
|
||||||
(loop (cadr entry))
|
(loop (cadr entry))
|
||||||
(loop (car entry)))]
|
(loop (car entry)))]
|
||||||
[else (error "bad entry")]))]
|
[else (error "bad entry")]))]
|
||||||
[content (if (symbol? entry)
|
[content (if (symbol? entry)
|
||||||
(with-handlers ([not-break? (lambda (x) #f)])
|
(with-handlers ([not-break? (lambda (x) #f)])
|
||||||
(let ([s (read p)])
|
(let ([s (read p)])
|
||||||
(if (eq? s '::)
|
(if (eq? s '::)
|
||||||
(read p)
|
(read p)
|
||||||
#f)))
|
#f)))
|
||||||
#f)])
|
#f)])
|
||||||
(list
|
(list
|
||||||
; Make the keyword entry:
|
; Make the keyword entry:
|
||||||
(list (symbol->string key) ; the keyword name
|
(list (symbol->string key) ; the keyword name
|
||||||
(let ([p (open-output-string)])
|
(let ([p (open-output-string)])
|
||||||
(if content
|
(if content
|
||||||
(display content p)
|
(display content p)
|
||||||
(if (and (pair? entry)
|
(if (and (pair? entry)
|
||||||
(eq? (car entry) 'quote))
|
(eq? (car entry) 'quote))
|
||||||
(fprintf p "'~s" (cadr entry))
|
(fprintf p "'~s" (cadr entry))
|
||||||
(display entry p)))
|
(display entry p)))
|
||||||
(get-output-string p)) ; the text to display
|
(get-output-string p)) ; the text to display
|
||||||
(cadr doc) ; file
|
(cadr doc) ; file
|
||||||
start ; label (a position in this case)
|
start ; label (a position in this case)
|
||||||
"doc.txt")))] ; title
|
"doc.txt")))] ; title
|
||||||
[else #f]))))
|
[else #f]))))
|
||||||
|
|
||||||
(define re:index-line (regexp "_([^_]*)_(.*)"))
|
(define re:index-line (regexp "_([^_]*)_(.*)"))
|
||||||
(define text-indices (make-hash-table))
|
(define text-indices (make-hash-table))
|
||||||
(define (load-txt-index doc)
|
(define (load-txt-index doc)
|
||||||
(parse-txt-file
|
(parse-txt-file
|
||||||
(apply build-path doc)
|
(apply build-path doc)
|
||||||
text-indices
|
text-indices
|
||||||
(lambda (r start)
|
(lambda (r start)
|
||||||
(cond
|
(cond
|
||||||
[(regexp-match re:index-line r)
|
[(regexp-match re:index-line r)
|
||||||
=> (lambda (m)
|
=> (lambda (m)
|
||||||
(let loop ([m m])
|
(let loop ([m m])
|
||||||
(let ([s (cadr m)])
|
(let ([s (cadr m)])
|
||||||
(cons
|
(cons
|
||||||
; Make an index entry:
|
; Make an index entry:
|
||||||
(cons s start)
|
(cons s start)
|
||||||
(let ([m (regexp-match re:index-line (caddr m))])
|
(let ([m (regexp-match re:index-line (caddr m))])
|
||||||
(if m
|
(if m
|
||||||
(loop m)
|
(loop m)
|
||||||
null))))))]
|
null))))))]
|
||||||
[else #f]))))
|
[else #f]))))
|
||||||
|
|
||||||
(define re:splitter (regexp "^ *([^ ]+)(.*)"))
|
(define re:splitter (regexp "^ *([^ ]+)(.*)"))
|
||||||
(define (split-words s)
|
(define (split-words s)
|
||||||
(let ([m (regexp-match re:splitter s)])
|
(let ([m (regexp-match re:splitter s)])
|
||||||
(if m
|
(if m
|
||||||
(cons (cadr m)
|
(cons (cadr m)
|
||||||
(split-words (caddr m)))
|
(split-words (caddr m)))
|
||||||
null)))
|
null)))
|
||||||
|
|
||||||
(define (non-regexp s)
|
(define (non-regexp s)
|
||||||
(list->string
|
(list->string
|
||||||
(apply
|
(apply
|
||||||
append
|
append
|
||||||
(map
|
(map
|
||||||
(lambda (c)
|
(lambda (c)
|
||||||
(cond
|
(cond
|
||||||
[(memq c '(#\$ #\| #\\ #\[ #\] #\. #\* #\? #\+ #\( #\) #\^))
|
[(memq c '(#\$ #\| #\\ #\[ #\] #\. #\* #\? #\+ #\( #\) #\^))
|
||||||
(list #\\ c)]
|
(list #\\ c)]
|
||||||
[(char-alphabetic? c)
|
[(char-alphabetic? c)
|
||||||
(list #\[ (char-upcase c) (char-downcase c) #\])]
|
(list #\[ (char-upcase c) (char-downcase c) #\])]
|
||||||
[else (list c)]))
|
[else (list c)]))
|
||||||
(string->list s)))))
|
(string->list s)))))
|
||||||
|
|
||||||
(define (doc-collections-changed)
|
(define (doc-collections-changed)
|
||||||
(set! doc-collection-date #f))
|
(set! doc-collection-date #f))
|
||||||
|
|
||||||
(define re:url-dir (regexp "^([^/]*)/(.*)$"))
|
(define re:url-dir (regexp "^([^/]*)/(.*)$"))
|
||||||
(define (combine-path/url-path path url-path)
|
(define (combine-path/url-path path url-path)
|
||||||
(let loop ([path path]
|
(let loop ([path path]
|
||||||
[url-path url-path])
|
[url-path url-path])
|
||||||
(cond
|
(cond
|
||||||
[(regexp-match re:url-dir url-path)
|
[(regexp-match re:url-dir url-path)
|
||||||
=>
|
=>
|
||||||
(lambda (m)
|
(lambda (m)
|
||||||
(let* ([url-dir (cadr m)]
|
(let* ([url-dir (cadr m)]
|
||||||
[rest (caddr m)]
|
[rest (caddr m)]
|
||||||
[dir
|
[dir
|
||||||
(cond
|
(cond
|
||||||
[(string=? ".." url-dir) 'up]
|
[(string=? ".." url-dir) 'up]
|
||||||
[(string=? "." url-dir) 'same]
|
[(string=? "." url-dir) 'same]
|
||||||
[(string=? "" url-dir) 'same]
|
[(string=? "" url-dir) 'same]
|
||||||
[else url-dir])])
|
[else url-dir])])
|
||||||
(loop (build-path path dir)
|
(loop (build-path path dir)
|
||||||
rest)))]
|
rest)))]
|
||||||
[else (build-path path url-path)])))
|
[else (build-path path url-path)])))
|
||||||
|
|
||||||
;; do-search : ((? -> ?)
|
; do-search : ((? -> ?)
|
||||||
;; ??
|
; ??
|
||||||
;; boolean
|
; boolean
|
||||||
;; boolean
|
; boolean
|
||||||
;; ??
|
; ??
|
||||||
;; (-> A) ;; doesn't return
|
; (-> A) ; doesn't return
|
||||||
;; (?? -> ??)
|
; (?? -> ??)
|
||||||
;; (?? -> ??)
|
; (?? -> ??)
|
||||||
;; (?? ?? ?? ?? ?? ?? -> ??)
|
; (?? ?? ?? ?? ?? ?? -> ??)
|
||||||
;; ->
|
; ->
|
||||||
;; (union string #f))
|
; (union string #f))
|
||||||
(define (do-search given-find search-level regexp? exact? ckey maxxed-out
|
(define (do-search given-find search-level regexp? exact? ckey maxxed-out
|
||||||
add-doc-section add-kind-section add-choice)
|
add-doc-section add-kind-section add-choice)
|
||||||
; When new docs are installed, the directory's modification date changes:
|
; When new docs are installed, the directory's modification date changes:
|
||||||
(unless (eq? doc-collection-date 'none)
|
(unless (eq? doc-collection-date 'none)
|
||||||
(when (or (not doc-collection-date)
|
(when (or (not doc-collection-date)
|
||||||
(> (file-or-directory-modify-seconds (collection-path "doc"))
|
(> (file-or-directory-modify-seconds (collection-path "doc"))
|
||||||
doc-collection-date))
|
doc-collection-date))
|
||||||
(reset-doc-lists)))
|
(reset-doc-lists)))
|
||||||
(let* ([hit-count 0]
|
(let* ([hit-count 0]
|
||||||
[string-finds (list given-find)]
|
[string-finds (list given-find)]
|
||||||
[finds (cond
|
[finds (cond
|
||||||
[exact? (list given-find)]
|
[exact? (list given-find)]
|
||||||
[regexp? (list (regexp given-find))]
|
[regexp? (list (regexp given-find))]
|
||||||
[else (let ([wl (split-words given-find)])
|
[else (let ([wl (split-words given-find)])
|
||||||
(set! string-finds wl)
|
(set! string-finds wl)
|
||||||
(map regexp (map non-regexp wl)))])])
|
(map regexp (map non-regexp wl)))])])
|
||||||
(for-each
|
(for-each
|
||||||
(lambda (doc doc-name doc-kind)
|
(lambda (doc doc-name doc-kind)
|
||||||
(define found-one #f)
|
(define found-one #f)
|
||||||
(define (found kind)
|
(define (found kind)
|
||||||
(unless found-one
|
(unless found-one
|
||||||
(add-doc-section doc-name ckey))
|
(add-doc-section doc-name ckey))
|
||||||
(unless (equal? found-one kind)
|
(unless (equal? found-one kind)
|
||||||
(set! found-one kind)
|
(set! found-one kind)
|
||||||
(add-kind-section kind ckey))
|
(add-kind-section kind ckey))
|
||||||
(set! hit-count (add1 hit-count))
|
(set! hit-count (add1 hit-count))
|
||||||
(unless (< hit-count MAX-HIT-COUNT)
|
(unless (< hit-count MAX-HIT-COUNT)
|
||||||
(maxxed-out)))
|
(maxxed-out)))
|
||||||
|
|
||||||
;; Keyword search
|
; Keyword search
|
||||||
(let ([keys (case doc-kind
|
(let ([keys (case doc-kind
|
||||||
[(html) (load-html-keywords doc)]
|
[(html) (load-html-keywords doc)]
|
||||||
[(text) (load-txt-keywords doc)]
|
[(text) (load-txt-keywords doc)]
|
||||||
[else null])]
|
[else null])]
|
||||||
[add-key-choice (lambda (v)
|
[add-key-choice (lambda (v)
|
||||||
(found "keyword entries")
|
(found "keyword entries")
|
||||||
(add-choice
|
(add-choice
|
||||||
(car v) ; key
|
(car v) ; key
|
||||||
(cadr v) ; display
|
(cadr v) ; display
|
||||||
(list-ref v 4) ; title
|
(list-ref v 4) ; title
|
||||||
(if (eq? 'text doc-kind)
|
(if (eq? 'text doc-kind)
|
||||||
(apply build-path doc)
|
(apply build-path doc)
|
||||||
(build-path doc (list-ref v 2))) ; file
|
(build-path doc (list-ref v 2))) ; file
|
||||||
(list-ref v 3) ; label
|
(list-ref v 3) ; label
|
||||||
ckey))])
|
ckey))])
|
||||||
|
|
||||||
(unless regexp?
|
(unless regexp?
|
||||||
(for-each
|
(for-each
|
||||||
(lambda (v)
|
(lambda (v)
|
||||||
(when (string=? given-find (car v))
|
(when (string=? given-find (car v))
|
||||||
(add-key-choice v)))
|
(add-key-choice v)))
|
||||||
keys))
|
keys))
|
||||||
(unless (or exact? (null? finds))
|
(unless (or exact? (null? finds))
|
||||||
(for-each
|
(for-each
|
||||||
(lambda (v)
|
(lambda (v)
|
||||||
(when (andmap (lambda (find) (regexp-match find (car v))) finds)
|
(when (andmap (lambda (find) (regexp-match find (car v))) finds)
|
||||||
(unless (and (not regexp?) (string=? given-find (car v)))
|
(unless (and (not regexp?) (string=? given-find (car v)))
|
||||||
(add-key-choice v))))
|
(add-key-choice v))))
|
||||||
keys)))
|
keys)))
|
||||||
;; Index search
|
; Index search
|
||||||
(unless (< search-level 1)
|
(unless (< search-level 1)
|
||||||
(let ([index (case doc-kind
|
(let ([index (case doc-kind
|
||||||
[(html) (load-html-index doc)]
|
[(html) (load-html-index doc)]
|
||||||
[(text) (load-txt-index doc)]
|
[(text) (load-txt-index doc)]
|
||||||
[else null])]
|
[else null])]
|
||||||
[add-index-choice (lambda (name desc)
|
[add-index-choice (lambda (name desc)
|
||||||
(case doc-kind
|
(case doc-kind
|
||||||
[(html)
|
[(html)
|
||||||
(found "index entries")
|
(found "index entries")
|
||||||
(add-choice "" name
|
(add-choice "" name
|
||||||
(list-ref desc 2)
|
(list-ref desc 2)
|
||||||
(combine-path/url-path doc (list-ref desc 0))
|
(combine-path/url-path doc (list-ref desc 0))
|
||||||
(list-ref desc 1)
|
(list-ref desc 1)
|
||||||
ckey)]
|
ckey)]
|
||||||
[(text)
|
[(text)
|
||||||
(found "index entries")
|
(found "index entries")
|
||||||
(add-choice "" name
|
(add-choice "" name
|
||||||
"indexed content"
|
"indexed content"
|
||||||
(apply build-path doc)
|
(apply build-path doc)
|
||||||
desc
|
desc
|
||||||
ckey)]))])
|
ckey)]))])
|
||||||
(when index
|
(when index
|
||||||
(unless regexp?
|
(unless regexp?
|
||||||
(for-each
|
(for-each
|
||||||
(lambda (v)
|
(lambda (v)
|
||||||
(when (string=? given-find (car v))
|
(when (string=? given-find (car v))
|
||||||
(add-index-choice (car v) (cdr v))))
|
(add-index-choice (car v) (cdr v))))
|
||||||
index))
|
index))
|
||||||
(unless (or exact? (null? finds))
|
(unless (or exact? (null? finds))
|
||||||
(for-each
|
(for-each
|
||||||
(lambda (v)
|
(lambda (v)
|
||||||
(when (andmap (lambda (find) (regexp-match find (car v))) finds)
|
(when (andmap (lambda (find) (regexp-match find (car v))) finds)
|
||||||
(unless (and (not regexp?) (string=? given-find (car v)))
|
(unless (and (not regexp?) (string=? given-find (car v)))
|
||||||
(add-index-choice (car v) (cdr v)))))
|
(add-index-choice (car v) (cdr v)))))
|
||||||
index)))))
|
index)))))
|
||||||
;; Content Search
|
; Content Search
|
||||||
(unless (or (< search-level 2) exact? (null? finds))
|
(unless (or (< search-level 2) exact? (null? finds))
|
||||||
(let ([files (case doc-kind
|
(let ([files (case doc-kind
|
||||||
[(html) (with-handlers ([not-break? (lambda (x) null)])
|
[(html) (with-handlers ([not-break? (lambda (x) null)])
|
||||||
(map (lambda (x) (build-path doc x))
|
(map (lambda (x) (build-path doc x))
|
||||||
(filter
|
(filter
|
||||||
(lambda (x) (file-exists? (build-path doc x)))
|
(lambda (x) (file-exists? (build-path doc x)))
|
||||||
(directory-list doc))))]
|
(directory-list doc))))]
|
||||||
[(text) (list (apply build-path doc))]
|
[(text) (list (apply build-path doc))]
|
||||||
[else null])])
|
[else null])])
|
||||||
(for-each
|
(for-each
|
||||||
(lambda (f)
|
(lambda (f)
|
||||||
(with-handlers ([not-break? (lambda (x) #f)])
|
(with-handlers ([not-break? (lambda (x) #f)])
|
||||||
(with-input-from-file f
|
(with-input-from-file f
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(let loop ()
|
(let loop ()
|
||||||
(let ([pos (file-position (current-input-port))]
|
(let ([pos (file-position (current-input-port))]
|
||||||
[r (read-line)])
|
[r (read-line)])
|
||||||
(unless (eof-object? r)
|
(unless (eof-object? r)
|
||||||
(let ([m (andmap (lambda (find) (regexp-match find r)) finds)])
|
(let ([m (andmap (lambda (find) (regexp-match find r)) finds)])
|
||||||
(when m
|
(when m
|
||||||
(found "text")
|
(found "text")
|
||||||
(add-choice (car m)
|
(add-choice (car m)
|
||||||
; Strip leading space and clean HTML
|
; Strip leading space and clean HTML
|
||||||
(regexp-replace
|
(regexp-replace
|
||||||
"^ [ ]*"
|
"^ [ ]*"
|
||||||
(if (eq? doc-kind 'html)
|
(if (eq? doc-kind 'html)
|
||||||
(clean-html r)
|
(clean-html r)
|
||||||
r)
|
r)
|
||||||
"")
|
"")
|
||||||
"content"
|
"content"
|
||||||
f
|
f
|
||||||
(if (eq? doc-kind 'text) pos "NO TAG")
|
(if (eq? doc-kind 'text) pos "NO TAG")
|
||||||
ckey)))
|
ckey)))
|
||||||
(loop))))))))
|
(loop))))))))
|
||||||
files))))
|
files))))
|
||||||
docs doc-names doc-kinds)
|
docs doc-names doc-kinds)
|
||||||
(if (= 0 hit-count)
|
(if (= 0 hit-count)
|
||||||
(apply
|
(apply
|
||||||
string-append
|
string-append
|
||||||
"Nothing found for "
|
"Nothing found for "
|
||||||
(cond
|
(cond
|
||||||
[(null? string-finds) (list "the empty search.")]
|
[(null? string-finds) (list "the empty search.")]
|
||||||
[else
|
[else
|
||||||
(append
|
(append
|
||||||
(cons (format "\"~a\"" (car string-finds))
|
(cons (format "\"~a\"" (car string-finds))
|
||||||
(map (lambda (i) (format " and \"~a\"" i))
|
(map (lambda (i) (format " and \"~a\"" i))
|
||||||
(cdr string-finds)))
|
(cdr string-finds)))
|
||||||
(list "."))]))
|
(list "."))]))
|
||||||
#f))))
|
#f))))))
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user