suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

Factored out MrEd deps

Browse Source 
original commit: ce0919821999ded657ad5338db774b52ea328119
This commit is contained in:
Paul Steckler 2002-07-16 16:58:34 +00:00
parent 6086973b8b
commit 6e18cdd287
2 changed files with 67 additions and 103 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

140
collects/help/help.ss
View File

@ -1,11 +1,7 @@
(module help mzscheme
(require (lib "web-server.ss" "web-server")
(lib "util.ss" "web-server")
(lib "class.ss")
(require (lib "class.ss")
(lib "mred.ss" "mred")
(lib "cmdline.ss")
(lib "configuration.ss" "web-server")
(lib "configuration-structures.ss" "web-server")
"private/server.ss"
"private/browser.ss")
@ -40,86 +36,81 @@
(define help-desk-port (hd-cookie->port hd-cookie))
; allow server startup time
(let loop ()
(with-handlers
([void (lambda _ (sleep 1) (loop))])
(let-values
([(iport oport) (tcp-connect "127.0.0.1" help-desk-port)])
(sleep 1)
(close-output-port oport)
(close-input-port iport))))
(wait-for-connection help-desk-port)
(when launch-browser?
(help-desk-browser hd-cookie)
; allow browser startup time
; allow browser startup time
(sleep 2))
(if quiet?
(semaphore-wait (make-semaphore 0))
(let* ([hd-frame%
(class frame%
(inherit show)
(field
[panel #f]
[main-sd-button #f]
[shutdown-dialog
(lambda ()
(let* ([cb-frame (instantiate frame% ()
(label "Confirm"))]
[vpanel (instantiate vertical-panel% ()
(parent cb-frame))]
[msg (instantiate message% ()
(label "Really shutdown Help Desk server?")
(parent vpanel))]
[hpanel (instantiate horizontal-panel% ()
(parent vpanel)
(alignment '(center center)))]
[sd-button (instantiate button% ()
(label "Shutdown")
(parent hpanel)
(callback (lambda (b ev)
(send cb-frame show #f)
(send this show #f))))]
[no-sd-button (instantiate button% ()
(label "Cancel")
(parent hpanel)
(callback (lambda (b ev)
(send main-sd-button
enable #t)
(send cb-frame show #f))))])
(send main-sd-button enable #f)
(send cb-frame center)
(send cb-frame show #t)))])
(define/override can-close?
(lambda () (shutdown-dialog) #f))
(super-instantiate ())
(set! panel
(instantiate vertical-panel% ()
(parent this)))
(instantiate message% ()
(label (format "Help Desk server running on port ~a"
(hd-cookie->port hd-cookie)))
(parent panel))
(instantiate button% ()
(label "Help Desk Home")
(parent panel)
(min-width 100)
(callback
(lambda (b ev)
(help-desk-browser hd-cookie))))
(set! main-sd-button
(instantiate button% ()
(label "Shutdown Server")
(parent panel)
(min-width 100)
(callback (lambda (b ev)
(shutdown-dialog))))))]
(inherit show)
(field
[panel #f]
[main-sd-button #f]
[shutdown-dialog
(lambda ()
(let* ([cb-frame (instantiate frame% ()
(label "Confirm"))]
[vpanel (instantiate vertical-panel% ()
(parent cb-frame))]
[msg (instantiate message% ()
(label "Really shutdown Help Desk server?")
(parent vpanel))]
[hpanel (instantiate horizontal-panel% ()
(parent vpanel)
(alignment '(center center)))]
[sd-button (instantiate button% ()
(label "Shutdown")
(parent hpanel)
(callback
(lambda (b ev)
(send cb-frame show #f)
(send this show #f))))]
[no-sd-button (instantiate button% ()
(label "Cancel")
(parent hpanel)
(callback
(lambda (b ev)
(send main-sd-button
enable #t)
(send cb-frame show #f))))])
(send main-sd-button enable #f)
(send cb-frame center)
(send cb-frame show #t)))])
(define/override can-close?
(lambda () (shutdown-dialog) #f))
(super-instantiate ())
(set! panel
(instantiate vertical-panel% ()
(parent this)))
(instantiate message% ()
(label (format "Help Desk server running on port ~a"
(hd-cookie->port hd-cookie)))
(parent panel))
(instantiate button% ()
(label "Help Desk Home")
(parent panel)
(min-width 100)
(callback
(lambda (b ev)
(help-desk-browser hd-cookie))))
(set! main-sd-button
(instantiate button% ()
(label "Shutdown Server")
(parent panel)
(min-width 100)
(callback (lambda (b ev)
(shutdown-dialog))))))]
[frame
(instantiate hd-frame% ()
(label "PLT Help Desk")
(min-width 175)
(stretchable-width #f)
(stretchable-height #f))])
(label "PLT Help Desk")
(min-width 175)
(stretchable-width #f)
(stretchable-height #f))])
(send frame center)
(send frame show #t)
(when iconize?
@ -135,3 +126,4 @@

30
collects/help/private/search.ss
View File

@ -3,40 +3,12 @@
"docpos.ss"
"colldocs.ss"
"server.ss"
"browser.ss"
(lib "list.ss")
(lib "util.ss" "help" "servlets" "private")
(lib "specs.ss" "framework"))
(lib "util.ss" "help" "servlets" "private"))
(provide do-search
doc-collections-changed)
(provide/contract
(search-for-docs
(hd-cookie? string?
(lambda (s)
(member s
'("keyword" "keyword-index" "keyword-index-text")))
(lambda (s)
(member s
'("exact-match" "containing-match" "regexp-match")))
any?
. -> . any?)))
; hd-cookie string string string any -> void
; shows search result in default browser
(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)
(or (user-defined-doc-position x)
(standard-html-doc-position x)))