282 lines
8.0 KiB
Scheme
282 lines
8.0 KiB
Scheme
|
|
(require-library "browser.ss" "browser")
|
|
|
|
(define f (make-object (class frame% args
|
|
(override [on-close exit])
|
|
(sequence (apply super-init args)))
|
|
"PLT Help" #f 600 440))
|
|
(define html-panel (make-object hyper-panel% f))
|
|
(define results (send html-panel get-canvas))
|
|
|
|
(define top (make-object vertical-pane% f))
|
|
(define t (make-object text-field% "Find help on:" top void))
|
|
(define search-pane (make-object horizontal-pane% top))
|
|
(define button (make-object button% "Search" search-pane (lambda (b e) (set! collecting-thread (thread start-search))) '(border)))
|
|
(define where (make-object choice% #f '("for Keyword"
|
|
"for Keyword or Index Entry"
|
|
"for Keyword, Index Entry, or Text")
|
|
search-pane void))
|
|
(define exact (make-object choice% #f '("exact match"
|
|
"containing match"
|
|
"regexp match")
|
|
search-pane void))
|
|
(define stop (make-object button% "Stop" search-pane
|
|
(lambda (b e)
|
|
(break-thread collecting-thread))))
|
|
|
|
(send exact set-selection 1)
|
|
(send stop show #f)
|
|
|
|
(define results-editor% (class hyper-text% ()
|
|
(inherit set-title)
|
|
(sequence
|
|
(super-init #f)
|
|
(set-title "Search Results"))))
|
|
|
|
(send top stretchable-height #f)
|
|
|
|
(send t focus)
|
|
|
|
(let* ([mb (make-object menu-bar% f)]
|
|
[file (make-object menu% "&File" mb)]
|
|
[edit (make-object menu% "&Edit" mb)])
|
|
(append-editor-operation-menu-items edit)
|
|
|
|
(make-object menu-item% "Quit" file (lambda (i e) (exit)) #\Q))
|
|
|
|
(send f show #t)
|
|
|
|
(send results goto-url
|
|
(string-append "file:" (build-path (collection-path "doc") "start.htm"))
|
|
#f)
|
|
|
|
(define cycle-key #f)
|
|
(define collecting-thread #f)
|
|
|
|
(define choices-sema (make-semaphore 1))
|
|
(define choices null)
|
|
|
|
(define (add-choice type name title page label ckey)
|
|
(semaphore-wait choices-sema)
|
|
(set! choices (cons (list type name title page label) choices))
|
|
(semaphore-post choices-sema)
|
|
(queue-callback
|
|
(lambda ()
|
|
(when (eq? cycle-key ckey)
|
|
(semaphore-wait choices-sema)
|
|
(let ([l choices]
|
|
[editor (send results get-editor)])
|
|
(set! choices null)
|
|
(semaphore-post choices-sema)
|
|
(send editor begin-edit-sequence)
|
|
(for-each
|
|
(lambda (i)
|
|
(let-values ([(type name title page label) (apply values i)])
|
|
(if type
|
|
(begin
|
|
(send editor insert " " (send editor last-position) 'same #f)
|
|
(let ([start (send editor last-position)])
|
|
(send editor insert name start 'same #f)
|
|
(let ([end (send editor last-position)])
|
|
(send editor insert (format " in ~s~n" title) end 'same #f)
|
|
(send editor make-link-style start end)
|
|
(send editor set-clickback start end
|
|
(lambda (edit start end)
|
|
(send results goto-url
|
|
(make-url
|
|
"file"
|
|
#f ; host
|
|
#f ; port
|
|
page
|
|
#f ; params
|
|
#f ; query
|
|
label)
|
|
#f))))))
|
|
(begin
|
|
(send editor insert (format "In ~a:~n" name) (send editor last-position) 'same #f)))))
|
|
(reverse l))
|
|
(send editor end-edit-sequence))))
|
|
#f))
|
|
|
|
(define (add-section name ckey)
|
|
(add-choice #f name #f #f #f ckey))
|
|
|
|
(define re:iname (regexp "A HREF=\"(node[0-9]*[.]htm)\"><IMG SRC=\"../icons/index.gif"))
|
|
(define re:ientry (regexp "<DT>(.*)<DD>"))
|
|
(define re:ilink (regexp "(.*)<A HREF=\"(node[0-9]*[.]htm)#([0-9]*)\">(.*)</A>"))
|
|
|
|
(define indices (make-hash-table))
|
|
|
|
(define (clean-index-entry s)
|
|
(regexp-replace*
|
|
"<[^>]*>"
|
|
(regexp-replace*
|
|
">"
|
|
(regexp-replace*
|
|
"<"
|
|
s
|
|
"<")
|
|
">")
|
|
""))
|
|
|
|
(define (load-index doc)
|
|
(hash-table-get
|
|
indices
|
|
(string->symbol doc)
|
|
(lambda ()
|
|
(let ([index-file (with-handlers ([(lambda (x) (not (exn:misc:user-break? x))) (lambda (x) #f)])
|
|
(with-input-from-file (build-path doc "index.htm")
|
|
(lambda ()
|
|
(let loop ()
|
|
(let ([r (read-line)])
|
|
(cond
|
|
[(eof-object? r) #f]
|
|
[(regexp-match re:iname r)
|
|
=>
|
|
(lambda (m) (cadr m))]
|
|
[else (loop)]))))))])
|
|
(let ([index
|
|
(and index-file
|
|
(with-handlers ([(lambda (x) (not (exn:misc:user-break? x)))
|
|
(lambda (x)
|
|
; (printf "~a~n" (exn-message x))
|
|
#f)])
|
|
(with-input-from-file (build-path doc index-file)
|
|
(lambda ()
|
|
(let loop ()
|
|
(let ([r (read-line)])
|
|
(if (eof-object? r)
|
|
null
|
|
(let ([m (regexp-match re:ientry r)])
|
|
(if m
|
|
(cons (cons (clean-index-entry (cadr m)) r)
|
|
(loop))
|
|
(loop))))))))))])
|
|
(hash-table-put! indices (string->symbol doc) index)
|
|
index)))))
|
|
|
|
(define (non-regexp s)
|
|
(list->string
|
|
(apply
|
|
append
|
|
(map
|
|
(lambda (c)
|
|
(if (memq c '(#\$ #\| #\\ #\[ #\] #\. #\* #\? #\+ #\( #\)))
|
|
(list #\\ c)
|
|
(list c)))
|
|
(string->list s)))))
|
|
|
|
(define (start-search)
|
|
(let* ([given-find (send t get-value)]
|
|
[find (let ([s given-find])
|
|
(case (send exact get-selection)
|
|
[(0) s]
|
|
[(1) (regexp (non-regexp s))] ; substring (not regexp) match
|
|
[else (regexp s)]))]
|
|
[search-level (send where get-selection)]
|
|
[regexp? (= 2 (send exact get-selection))]
|
|
[exact? (= 0 (send exact get-selection))]
|
|
[ckey (gensym)]
|
|
[editor (let ([e (send results get-editor)])
|
|
(if (is-a? e results-editor%)
|
|
e
|
|
(let ([e (make-object results-editor%)])
|
|
(send results set-page (editor->page e) #t)
|
|
e)))])
|
|
(dynamic-wind
|
|
(lambda ()
|
|
(begin-busy-cursor)
|
|
(send html-panel enable #f)
|
|
(send button enable #f)
|
|
(send where enable #f)
|
|
(send exact enable #f)
|
|
(set! cycle-key ckey))
|
|
(lambda ()
|
|
(with-handlers ([exn:misc:user-break?
|
|
(lambda (x)
|
|
(queue-callback
|
|
(lambda ()
|
|
(when (eq? cycle-key ckey)
|
|
(send editor insert "(Search stopped.)" (send editor last-position) 'same #f)))
|
|
#f))])
|
|
(send stop show #t)
|
|
(send editor erase)
|
|
(let* ([path (collection-path "doc")]
|
|
[doc-names (directory-list path)]
|
|
[docs (map (lambda (x) (build-path path x)) doc-names)])
|
|
(for-each
|
|
(lambda (doc doc-name)
|
|
(define found-one? #f)
|
|
(define (found)
|
|
(unless found-one?
|
|
(set! found-one? #t)
|
|
(add-section doc-name ckey)))
|
|
;; Keyword search
|
|
(let ([keywords (build-path doc "keywords")])
|
|
(when (file-exists? keywords)
|
|
(let ([keys (with-input-from-file keywords read)]
|
|
[add-key-choice (lambda (v)
|
|
(found)
|
|
(add-choice
|
|
"key" (cadr v) (list-ref v 4)
|
|
(build-path doc (list-ref v 2))
|
|
(list-ref v 3)
|
|
ckey))])
|
|
(unless regexp?
|
|
(for-each
|
|
(lambda (v)
|
|
(when (string=? given-find (car v))
|
|
(add-key-choice v)))
|
|
keys))
|
|
(unless exact?
|
|
(for-each
|
|
(lambda (v)
|
|
(when (regexp-match find (car v))
|
|
(unless (and (not regexp?) (string=? given-find (car v)))
|
|
(add-key-choice v))))
|
|
keys)))))
|
|
;; Index search
|
|
(unless (< search-level 1)
|
|
(let ([index (load-index doc)]
|
|
[add-index-choice (lambda (name desc)
|
|
(let loop ([desc desc])
|
|
(let ([m (regexp-match re:ilink desc)])
|
|
(when m
|
|
(loop (list-ref m 1))
|
|
(found)
|
|
(add-choice "idx" name
|
|
(clean-index-entry (list-ref m 4))
|
|
(build-path doc (list-ref m 2))
|
|
(clean-index-entry (list-ref m 3))
|
|
ckey)))))])
|
|
(when index
|
|
(unless regexp?
|
|
(for-each
|
|
(lambda (v)
|
|
(when (string=? given-find (car v))
|
|
(add-index-choice (car v) (cdr v))))
|
|
index))
|
|
(unless exact?
|
|
(for-each
|
|
(lambda (v)
|
|
(when (regexp-match find (car v))
|
|
(unless (and (not regexp?) (string=? given-find (car v)))
|
|
(add-index-choice (car v) (cdr v)))))
|
|
index))))))
|
|
docs doc-names))
|
|
(queue-callback
|
|
(lambda ()
|
|
(when (eq? cycle-key ckey)
|
|
(when (zero? (send editor last-position))
|
|
(send editor insert (format "Found nothing for \"~a\"." given-find)))))
|
|
#f)))
|
|
(lambda ()
|
|
(send stop show #f)
|
|
(send html-panel enable #t)
|
|
(send button enable #t)
|
|
(send where enable #t)
|
|
(send exact enable #t)
|
|
(end-busy-cursor)))))
|
|
|
|
(yield (make-semaphore 0))
|