diff --git a/collects/help/help.ss b/collects/help/help.ss
index 491087dd..b681ffd6 100644
--- a/collects/help/help.ss
+++ b/collects/help/help.ss
@@ -1,66 +1,130 @@
(require-library "browser.ss" "browser")
-(define f (make-object frame% "PLT Help" #f 400 400))
-(define top (make-object vertical-pane% f))
-(define results (make-object editor-canvas% f))
+(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 t (make-object text-field% "Help on:" top void))
+(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) (start-search)) '(border)))
+(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 check-box% "Exact" search-pane void))
+ 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))))
-(define editor (make-object text%))
-(send results set-editor editor)
+(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)
-(define link-delta (make-object style-delta% 'change-underline #t))
-(let ([mult (send link-delta get-foreground-mult)]
- [add (send link-delta get-foreground-add)])
- (send mult set 0 0 0)
- (send add set 0 0 255))
+(send results goto-url
+ (string-append "file:" (build-path (collection-path "doc") "start.htm"))
+ #f)
-(define (add-choice type name title page label)
- (send editor insert (format "~a " type) (send editor last-position))
- (let ([start (send editor last-position)])
- (send editor begin-edit-sequence)
- (send editor insert (format "~a in ~s~n" name title) start)
- (let ([end (sub1 (send editor last-position))])
- (send editor change-style link-delta start end)
- (send editor set-clickback start end
- (lambda (edit start end)
- (open-url (make-url
- "file"
- #f ; host
- #f ; port
- page
- #f ; params
- #f ; query
- label)))))
- (send editor end-edit-sequence)))
+(define cycle-key #f)
+(define collecting-thread #f)
-(define re:iname "A HREF=\"(node[0-9]*[.]htm)\"><IMG SRC=\"../icons/index.gif")
-(define re:ientry "<DT><TT>([^<]*)</TT>")
-(define re:ilink "<A HREF=\"(node[0-9]*[.]htm)#([0-9]*)\">([^<]*)</A>(.*)")
+(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) #t) (lambda (x) #f)])
+ (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 ()
@@ -73,7 +137,10 @@
[else (loop)]))))))])
(let ([index
(and index-file
- (with-handlers ([(lambda (x) #f) (lambda (x) #f)])
+ (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 ()
@@ -82,75 +149,133 @@
null
(let ([m (regexp-match re:ientry r)])
(if m
- (cons (cons (cadr m) r) (loop))
+ (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 ([find (send t get-value)]
- [search-level (send where get-selection)]
- [exact? (send exact get-value)])
+ (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))
+ (send exact enable #f)
+ (set! cycle-key ckey))
(lambda ()
- (send editor erase)
- (let* ([path (collection-path "doc")]
- [docs (map (lambda (x) (build-path path x)) (directory-list path))])
- ;; Keyword searches
- (for-each
- (lambda (doc)
- (let ([keywords (build-path doc "keywords")])
- (when (file-exists? keywords)
- (let ([keys (with-input-from-file keywords read)]
- [add-key-choice (lambda (v)
- (add-choice
- "key" (cadr v) (list-ref v 4)
- (build-path doc (list-ref v 2))
- (list-ref v 3)))])
- (let ([v (assoc find keys)])
- (when v (add-key-choice v)))
- (unless exact?
- (for-each
- (lambda (v)
- (when (regexp-match find (car v))
- (unless (string=? find (car v))
- (add-key-choice v))))
- keys))))))
- docs)
- ;; Index searches
- (unless (< search-level 1)
+ (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)
- (let ([index (load-index doc)]
- [add-index-choice (lambda (name desc)
- (let loop ([desc desc])
- (let ([m (regexp-match re:ilink desc)])
- (when m
- (add-choice "idx" name
- (list-ref m 3)
- (build-path doc (list-ref m 1))
- (list-ref m 2))
- (loop (list-ref m 4))))))])
- (when index
- (let ([v (assoc find index)])
- (when v (add-index-choice (car v) (cdr v))))
- (unless exact?
- (for-each
- (lambda (v)
- (when (regexp-match find (car v))
- (unless (string=? find (car v))
- (add-index-choice (car v) (cdr v)))))
- index)))))
- docs)))
- (when (zero? (send editor last-position))
- (send editor insert (format "Found nothing for ~a." find))))
+ (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)))))
+ (send exact enable #t)
+ (end-busy-cursor)))))
(yield (make-semaphore 0))