suzanne.soy/scribble-enhanced
1
0
Fork 0
Code Issues 1 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

.

Browse Source 
original commit: 6b36626bca7185d1fb530b98b8e1e3d28ad27689
This commit is contained in:
Matthew Flatt 1998-11-26 00:04:06 +00:00
parent 77d5983c44
commit 431bd91d9b
1 changed files with 219 additions and 94 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

313
collects/help/help.ss
View File

@ -1,66 +1,130 @@
(require-library "browser.ss" "browser") (require-library "browser.ss" "browser")
(define f (make-object frame% "PLT Help" #f 400 400)) (define f (make-object (class frame% args
(define top (make-object vertical-pane% f)) (override [on-close exit])
(define results (make-object editor-canvas% f)) (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 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" (define where (make-object choice% #f '("for Keyword"
"for Keyword or Index Entry" "for Keyword or Index Entry"
"for Keyword, Index Entry, or Text") "for Keyword, Index Entry, or Text")
search-pane search-pane void))
void)) (define exact (make-object choice% #f '("exact match"
(define exact (make-object check-box% "Exact" search-pane void)) "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 exact set-selection 1)
(send results set-editor editor) (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 top stretchable-height #f)
(send t focus) (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 f show #t)
(define link-delta (make-object style-delta% 'change-underline #t)) (send results goto-url
(let ([mult (send link-delta get-foreground-mult)] (string-append "file:" (build-path (collection-path "doc") "start.htm"))
[add (send link-delta get-foreground-add)]) #f)
(send mult set 0 0 0)
(send add set 0 0 255))
(define (add-choice type name title page label) (define cycle-key #f)
(send editor insert (format "~a " type) (send editor last-position)) (define collecting-thread #f)
(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 re:iname "A HREF=\"(node[0-9]*[.]htm)\"><IMG SRC=\"../icons/index.gif") (define choices-sema (make-semaphore 1))
(define re:ientry "<DT><TT>([^<]*)</TT>") (define choices null)
(define re:ilink "<A HREF=\"(node[0-9]*[.]htm)#([0-9]*)\">([^<]*)</A>(.*)")
(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 indices (make-hash-table))
(define (clean-index-entry s)
(regexp-replace*
"<[^>]*>"
(regexp-replace*
"&gt;"
(regexp-replace*
"&lt;"
s
"<")
">")
""))
(define (load-index doc) (define (load-index doc)
(hash-table-get (hash-table-get
indices indices
(string->symbol doc) (string->symbol doc)
(lambda () (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") (with-input-from-file (build-path doc "index.htm")
(lambda () (lambda ()
(let loop () (let loop ()
@ -73,7 +137,10 @@
[else (loop)]))))))]) [else (loop)]))))))])
(let ([index (let ([index
(and index-file (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) (with-input-from-file (build-path doc index-file)
(lambda () (lambda ()
(let loop () (let loop ()
@ -82,75 +149,133 @@
null null
(let ([m (regexp-match re:ientry r)]) (let ([m (regexp-match re:ientry r)])
(if m (if m
(cons (cons (cadr m) r) (loop)) (cons (cons (clean-index-entry (cadr m)) r)
(loop))
(loop))))))))))]) (loop))))))))))])
(hash-table-put! indices (string->symbol doc) index) (hash-table-put! indices (string->symbol doc) index)
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) (define (start-search)
(let ([find (send t get-value)] (let* ([given-find (send t get-value)]
[search-level (send where get-selection)] [find (let ([s given-find])
[exact? (send exact get-value)]) (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 (dynamic-wind
(lambda () (lambda ()
(begin-busy-cursor)
(send html-panel enable #f)
(send button enable #f) (send button enable #f)
(send where enable #f) (send where enable #f)
(send exact enable #f)) (send exact enable #f)
(set! cycle-key ckey))
(lambda () (lambda ()
(send editor erase) (with-handlers ([exn:misc:user-break?
(let* ([path (collection-path "doc")] (lambda (x)
[docs (map (lambda (x) (build-path path x)) (directory-list path))]) (queue-callback
;; Keyword searches (lambda ()
(for-each (when (eq? cycle-key ckey)
(lambda (doc) (send editor insert "(Search stopped.)" (send editor last-position) 'same #f)))
(let ([keywords (build-path doc "keywords")]) #f))])
(when (file-exists? keywords) (send stop show #t)
(let ([keys (with-input-from-file keywords read)] (send editor erase)
[add-key-choice (lambda (v) (let* ([path (collection-path "doc")]
(add-choice [doc-names (directory-list path)]
"key" (cadr v) (list-ref v 4) [docs (map (lambda (x) (build-path path x)) doc-names)])
(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)
(for-each (for-each
(lambda (doc) (lambda (doc doc-name)
(let ([index (load-index doc)] (define found-one? #f)
[add-index-choice (lambda (name desc) (define (found)
(let loop ([desc desc]) (unless found-one?
(let ([m (regexp-match re:ilink desc)]) (set! found-one? #t)
(when m (add-section doc-name ckey)))
(add-choice "idx" name ;; Keyword search
(list-ref m 3) (let ([keywords (build-path doc "keywords")])
(build-path doc (list-ref m 1)) (when (file-exists? keywords)
(list-ref m 2)) (let ([keys (with-input-from-file keywords read)]
(loop (list-ref m 4))))))]) [add-key-choice (lambda (v)
(when index (found)
(let ([v (assoc find index)]) (add-choice
(when v (add-index-choice (car v) (cdr v)))) "key" (cadr v) (list-ref v 4)
(unless exact? (build-path doc (list-ref v 2))
(for-each (list-ref v 3)
(lambda (v) ckey))])
(when (regexp-match find (car v)) (unless regexp?
(unless (string=? find (car v)) (for-each
(add-index-choice (car v) (cdr v))))) (lambda (v)
index))))) (when (string=? given-find (car v))
docs))) (add-key-choice v)))
(when (zero? (send editor last-position)) keys))
(send editor insert (format "Found nothing for ~a." find)))) (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 () (lambda ()
(send stop show #f)
(send html-panel enable #t)
(send button enable #t) (send button enable #t)
(send where enable #t) (send where enable #t)
(send exact enable #t))))) (send exact enable #t)
(end-busy-cursor)))))
(yield (make-semaphore 0)) (yield (make-semaphore 0))