649 lines
29 KiB
Scheme
649 lines
29 KiB
Scheme
(module gui (lib "a-unit.ss")
|
|
(require (lib "framework.ss" "framework")
|
|
(lib "mred.ss" "mred")
|
|
|
|
(lib "class.ss")
|
|
(lib "contract.ss")
|
|
(lib "etc.ss")
|
|
(lib "list.ss")
|
|
(lib "file.ss")
|
|
|
|
(lib "string-constant.ss" "string-constants")
|
|
(lib "external.ss" "browser")
|
|
|
|
(lib "browser-sig.ss" "browser")
|
|
(lib "url-sig.ss" "net")
|
|
(lib "url-structs.ss" "net")
|
|
(lib "uri-codec.ss" "net")
|
|
"sig.ss"
|
|
"../bug-report.ss"
|
|
(lib "bday.ss" "framework" "private")
|
|
|
|
"standard-urls.ss"
|
|
"docpos.ss"
|
|
"manuals.ss"
|
|
"get-help-url.ss"
|
|
|
|
"internal-hp.ss")
|
|
|
|
(import browser^ url^)
|
|
(export gui^)
|
|
|
|
(define help-desk-frame<%>
|
|
(interface (frame:standard-menus<%>)
|
|
order-manuals
|
|
get-language-name
|
|
change-search-to-status
|
|
set-search-status-contents
|
|
change-status-to-search))
|
|
|
|
(define bug-report/help-desk-mixin
|
|
(mixin (frame:standard-menus<%>) ()
|
|
(define/override (file-menu:create-open-recent?) #f)
|
|
(define/override (help-menu:about-string)
|
|
(string-constant plt:hd:about-help-desk))
|
|
(define/override (help-menu:about-callback i e)
|
|
(message-box (string-constant plt:hd:about-help-desk)
|
|
(format
|
|
(string-constant plt:hd:help-desk-about-string)
|
|
(version:version) 1995 2007)
|
|
this))
|
|
(define/override (help-menu:create-about?) #t)
|
|
(define/override (help-menu:after-about menu)
|
|
(make-object menu-item% (string-constant plt:hd:help-on-help) menu
|
|
(lambda (i e)
|
|
(message-box
|
|
(string-constant plt:hd:help-on-help)
|
|
(string-constant plt:hd:help-on-help-details)
|
|
this)))
|
|
(new menu-item%
|
|
(label (string-constant bug-report-submit-menu-item))
|
|
(parent menu)
|
|
(callback
|
|
(lambda (x y)
|
|
(help-desk:report-bug)))))
|
|
(super-new)))
|
|
|
|
(define (browser-scroll-frame-mixin %)
|
|
(class %
|
|
(inherit get-hyper-panel)
|
|
|
|
(define/override (on-subwindow-char w e)
|
|
(or (let ([txt (send (send (get-hyper-panel) get-canvas) get-editor)])
|
|
(and txt
|
|
(let ([km (send txt get-hyper-keymap)])
|
|
(send km handle-key-event txt e))))
|
|
(super on-subwindow-char w e)))
|
|
|
|
(super-new)))
|
|
|
|
;; redirect urls to outside pages to external browsers (depending on the preferences settings)
|
|
;; also catches links into documentation that isn't installed yet and sends that
|
|
;; to the missing manuals page.
|
|
(define make-catch-url-frame-mixin
|
|
(let ()
|
|
(define (catch-url-hyper-panel-mixin %)
|
|
(class %
|
|
(define/override (get-canvas%)
|
|
(catch-url-canvas-mixin (super get-canvas%)))
|
|
(super-new)))
|
|
|
|
(define (catch-url-canvas-mixin %)
|
|
(class %
|
|
|
|
(define/override (get-editor%) (hd-editor-mixin (super get-editor%)))
|
|
|
|
(define/override (remap-url url)
|
|
(cond
|
|
[(url? url)
|
|
(cond
|
|
|
|
;; .plt files are always internal, no matter where from
|
|
;; they will be caught elsewhere.
|
|
[(and (url-path url)
|
|
(not (null? (url-path url)))
|
|
(regexp-match #rx".plt$" (path/param-path (car (last-pair (url-path url))))))
|
|
url]
|
|
|
|
;; files on download.plt-scheme.org in /doc are considered
|
|
;; things that we should view in the browser itself.
|
|
[(is-download.plt-scheme.org/doc-url? url)
|
|
url]
|
|
|
|
;; one of the "collects" hosts:
|
|
[(and (equal? internal-port (url-port url))
|
|
(ormap (lambda (host)
|
|
(equal? host (url-host url)))
|
|
doc-hosts))
|
|
;; Two things can go wrong with the URL:
|
|
;; 1. The corresponding doc might not be installed
|
|
;; 2. There's a relative reference from X to Y, and
|
|
;; X and Y are installed in different directories,
|
|
;; so the host is wrong for Y
|
|
;; Resolve 2, then check 1.
|
|
(let* ([path (url-path url)]
|
|
[manual (and (pair? path)
|
|
(path/param-path (car path)))])
|
|
(if manual
|
|
;; Find out where this manual is really located:
|
|
(let* ([path (find-doc-directory (string->path manual))]
|
|
[real-url (and path
|
|
(get-help-url path))]
|
|
[url (if real-url
|
|
;; Use the actual host:
|
|
(make-url (url-scheme url)
|
|
(url-user url)
|
|
(url-host (string->url real-url))
|
|
(url-port url)
|
|
(url-path-absolute? url)
|
|
(url-path url)
|
|
(url-query url)
|
|
(url-fragment url))
|
|
;; Can't do better than the original URL?
|
|
;; The manual is not installed.
|
|
url)])
|
|
(if (or (not path)
|
|
(not (has-index-installed? path)))
|
|
;; Manual not installed...
|
|
(let ([doc-pr (assoc (string->path manual) known-docs)])
|
|
(string->url
|
|
(make-missing-manual-url manual
|
|
(cdr doc-pr)
|
|
(url->string url))))
|
|
;; Manual here; use revised URL
|
|
url))
|
|
;; Not a manual? Shouldn't happen.
|
|
url))]
|
|
|
|
;; one of the other internal hosts
|
|
[(and (equal? internal-port (url-port url))
|
|
(is-internal-host? (url-host url)))
|
|
url]
|
|
|
|
;; send the url off to another browser
|
|
[(and (string? (url-scheme url))
|
|
(not (member (url-scheme url) '("http"))))
|
|
(send-url (url->string url))
|
|
#f]
|
|
[(preferences:get 'drscheme:help-desk:ask-about-external-urls)
|
|
(case (ask-user-about-separate-browser)
|
|
[(separate)
|
|
(send-url (url->string url))
|
|
#f]
|
|
[(internal)
|
|
url]
|
|
[else #f])]
|
|
[(preferences:get 'drscheme:help-desk:separate-browser)
|
|
(send-url url)
|
|
#f]
|
|
[else url])]
|
|
[else url]))
|
|
(super-new)))
|
|
|
|
;; has-index-installed? : path -> boolean
|
|
(define (has-index-installed? path)
|
|
(and (get-index-file path) #t))
|
|
|
|
(define sk-bitmap #f)
|
|
|
|
(define hd-editor-mixin
|
|
(mixin (hyper-text<%> editor<%>) ()
|
|
(define/augment (url-allows-evaling? url)
|
|
(and (is-internal-host? (url-host url))
|
|
(equal? internal-port (url-port url))))
|
|
|
|
(define show-sk? #t)
|
|
|
|
(define/override (on-event evt)
|
|
(cond
|
|
[(and show-sk?
|
|
(sk-bday?)
|
|
(send evt button-down? 'right))
|
|
(let ([admin (get-admin)])
|
|
(let ([menu (new popup-menu%)])
|
|
(new menu-item%
|
|
(parent menu)
|
|
(label (string-constant happy-birthday-shriram))
|
|
(callback (lambda (x y)
|
|
(set! show-sk? #f)
|
|
(let ([wb (box 0)]
|
|
[hb (box 0)]
|
|
[xb (box 0)]
|
|
[yb (box 0)])
|
|
(send admin get-view xb yb wb hb)
|
|
(send admin needs-update (unbox xb) (unbox yb) (unbox wb) (unbox hb))))))
|
|
(send (get-canvas) popup-menu menu
|
|
(+ (send evt get-x) 1)
|
|
(+ (send evt get-y) 1))))]
|
|
[else (super on-event evt)]))
|
|
|
|
|
|
(inherit dc-location-to-editor-location get-admin)
|
|
(define/override (on-paint before? dc left top right bottom dx dy draw-caret)
|
|
(super on-paint before? dc left top right bottom dx dy draw-caret)
|
|
(when before?
|
|
(when (and show-sk? (sk-bday?))
|
|
(unless sk-bitmap
|
|
(set! sk-bitmap (make-object bitmap% (build-path (collection-path "icons") "sk.jpg"))))
|
|
|
|
(let ([admin (get-admin)])
|
|
(when admin
|
|
(let*-values ([(view-w view-h) (get-view-w/h admin)]
|
|
[(view-x view-y)
|
|
(values (- (/ view-w 2) (/ (send sk-bitmap get-width) 2))
|
|
(- view-h (send sk-bitmap get-height)))]
|
|
;; note: view coordinates are not exactly canvas dc coordinates
|
|
;; but they are off by a fixed amount (same on all platforms)
|
|
;; (note: dc-location in this method means canvas dc, which is
|
|
;; different from the dc coming in here (offscreen bitmaps))
|
|
[(editor-x editor-y) (dc-location-to-editor-location view-x view-y)]
|
|
[(dc-x dc-y) (values (+ editor-x dx)
|
|
(+ editor-y dy))])
|
|
(send dc draw-bitmap sk-bitmap dc-x dc-y)))))))
|
|
(define/private (get-view-w/h admin)
|
|
(let ([wb (box 0)]
|
|
[hb (box 0)])
|
|
(send admin get-view #f #f wb hb)
|
|
(values (unbox wb)
|
|
(unbox hb))))
|
|
|
|
(inherit get-canvas)
|
|
(define/override (init-browser-status-line top-level-window)
|
|
(send top-level-window change-search-to-status))
|
|
(define/override (update-browser-status-line top-level-window s)
|
|
(send top-level-window set-search-status-contents s))
|
|
(define/override (close-browser-status-line top-level-window)
|
|
(send top-level-window change-status-to-search))
|
|
|
|
(super-new)))
|
|
|
|
(lambda (%)
|
|
(class %
|
|
(define/override (get-hyper-panel%)
|
|
(catch-url-hyper-panel-mixin (super get-hyper-panel%)))
|
|
(super-new)))))
|
|
|
|
(define (is-download.plt-scheme.org/doc-url? url)
|
|
(and (equal? "download.plt-scheme.org" (url-host url))
|
|
(not (null? (url-path url)))
|
|
(equal? (path/param-path (car (url-path url))) "doc")))
|
|
|
|
;; ask-user-about-separate-browser : -> (union #f 'separate 'internal)
|
|
(define (ask-user-about-separate-browser)
|
|
(define separate-default? (preferences:get 'drscheme:help-desk:separate-browser))
|
|
|
|
(let-values ([(result checked?)
|
|
(message+check-box/custom
|
|
(string-constant help-desk)
|
|
(string-constant plt:hd:ask-about-separate-browser)
|
|
(string-constant dont-ask-again-always-current)
|
|
(string-constant plt:hd:homebrew-browser)
|
|
(string-constant plt:hd:separate-browser)
|
|
(string-constant cancel)
|
|
#f ; no parent
|
|
(cons
|
|
(if separate-default?
|
|
'default=2
|
|
'default=1)
|
|
'(no-default)))])
|
|
(when checked?
|
|
(preferences:set 'drscheme:help-desk:ask-about-external-urls #f))
|
|
(case result
|
|
[(2)
|
|
(preferences:set 'drscheme:help-desk:separate-browser #t)
|
|
'separate]
|
|
[(1)
|
|
(preferences:set 'drscheme:help-desk:separate-browser #f)
|
|
'internal]
|
|
[(#f 3)
|
|
#f]
|
|
[else (error 'ack)])))
|
|
|
|
(define make-help-desk-framework-mixin
|
|
(mixin (frame:searchable<%> frame:standard-menus<%>) ()
|
|
(define/override (get-text-to-search)
|
|
(send (send (send this get-hyper-panel) get-canvas) get-editor))
|
|
|
|
(define/override (file-menu:create-new?) #t)
|
|
(define/override (file-menu:new-callback x y) (new-help-desk))
|
|
|
|
(define/override (file-menu:create-open-recent?) #f)
|
|
|
|
(define/override (file-menu:create-open?) #f)
|
|
(define/override (file-menu:create-print?) #t)
|
|
|
|
(define/override (file-menu:print-callback x y)
|
|
(let ([ed (send (send (send this get-hyper-panel) get-canvas) get-editor)])
|
|
(and ed
|
|
(send ed print))))
|
|
|
|
(define/override (file-menu:between-open-and-revert file-menu)
|
|
(super file-menu:between-open-and-revert file-menu)
|
|
(instantiate menu:can-restore-menu-item% ()
|
|
(parent file-menu)
|
|
(callback (lambda (_1 _2) (open-url-callback)))
|
|
(label (string-constant open-url...)))
|
|
(instantiate menu:can-restore-menu-item% ()
|
|
(parent file-menu)
|
|
(label (string-constant reload))
|
|
(callback (lambda (_1 _2) (send (send this get-hyper-panel) reload)))))
|
|
|
|
(define/private (open-url-callback)
|
|
(let ([url (get-url-from-user this)])
|
|
(when url
|
|
(let* ([hp (send this get-hyper-panel)]
|
|
[hc (send hp get-canvas)])
|
|
(send hc goto-url url #f)))))
|
|
|
|
(define/override (on-size w h)
|
|
(preferences:set 'drscheme:help-desk:frame-width w)
|
|
(preferences:set 'drscheme:help-desk:frame-height h)
|
|
(super on-size w h))
|
|
|
|
(super-new
|
|
(width (preferences:get 'drscheme:help-desk:frame-width))
|
|
(height (preferences:get 'drscheme:help-desk:frame-height)))
|
|
|
|
(frame:reorder-menus this)))
|
|
|
|
(define make-search-button-mixin
|
|
(mixin (frame:basic<%> hyper-frame<%>) ()
|
|
(field [search-panel #f])
|
|
|
|
;; order-manuals : as in drscheme:language:language<%>
|
|
;; by default, search in all manuals
|
|
(define/public (order-manuals x) (values x #t))
|
|
|
|
;; the name of the language to put in the top of the search results,
|
|
;; or #f if nothing is to be put there.
|
|
(define/public (get-language-name) #f)
|
|
|
|
(define/override (make-root-area-container class parent)
|
|
(let* ([search-panel-parent (super make-root-area-container vertical-panel% parent)]
|
|
[main-panel (make-object class search-panel-parent)])
|
|
(set! search-panel (instantiate vertical-panel% ()
|
|
(parent search-panel-parent)
|
|
(stretchable-height #f)))
|
|
main-panel))
|
|
|
|
;; these methods have the same name as the methods in the browser.
|
|
;; they are called during super initialization, so they protect themselves...
|
|
(define/public (change-search-to-status)
|
|
(when search/status-panel
|
|
(send search/status-panel active-child status-panel)))
|
|
(define/public (set-search-status-contents s)
|
|
(when status-message
|
|
(send status-message set-label (trim-string 200 s))))
|
|
(define/private (trim-string n str)
|
|
(cond
|
|
[(<= (string-length str) n) str]
|
|
[else (string-append (substring str 0 98)
|
|
" ... "
|
|
(substring str (- (string-length str)
|
|
97)
|
|
(string-length str)))]))
|
|
|
|
(define/public (change-status-to-search)
|
|
(when search/status-panel
|
|
(send search/status-panel active-child field-panel)
|
|
(send search-field focus)))
|
|
|
|
(field [search/status-panel #f]
|
|
[field-panel #f]
|
|
[search-field #f]
|
|
[status-panel #f]
|
|
[status-message #f]
|
|
[choices-panel #f])
|
|
|
|
(super-new (label (string-constant help-desk)))
|
|
|
|
(let ([hp (send this get-hyper-panel)])
|
|
(send hp set-init-page home-page-url)
|
|
(send (send hp get-canvas) allow-tab-exit #t))
|
|
|
|
(inherit get-menu-bar get-hyper-panel)
|
|
(let ()
|
|
(define search-menu (instantiate menu% ()
|
|
(label (string-constant plt:hd:search))
|
|
(parent (get-menu-bar))))
|
|
(define search-menu-item (instantiate menu:can-restore-menu-item% ()
|
|
(label (string-constant plt:hd:search))
|
|
(parent search-menu)
|
|
(shortcut #\e)
|
|
(callback
|
|
(lambda (x y) (search-callback #f)))))
|
|
(define lucky-menu-item (instantiate menu:can-restore-menu-item% ()
|
|
(label (string-constant plt:hd:feeling-lucky))
|
|
(parent search-menu)
|
|
(shortcut #\u)
|
|
(callback
|
|
(lambda (x y) (search-callback #t)))))
|
|
(define stupid-internal-define-syntax1
|
|
(set! search/status-panel (new panel:single%
|
|
(parent search-panel)
|
|
(stretchable-width #t))))
|
|
(define stupid-internal-define-syntax2
|
|
(set! field-panel (new horizontal-panel% (parent search/status-panel))))
|
|
(define stupid-internal-define-syntax3
|
|
(set! status-panel (new horizontal-panel% (parent search/status-panel))))
|
|
(define stupid-internal-define-syntax4
|
|
(set! status-message (new message%
|
|
(parent status-panel)
|
|
(stretchable-width #t)
|
|
(label ""))))
|
|
(define stupid-internal-define-syntax5
|
|
(set! search-field (instantiate text-field% ()
|
|
(label (string-constant plt:hd:find-docs-for))
|
|
(callback (lambda (x y)
|
|
(let ([on? (not (equal? "" (send search-field get-value)))])
|
|
(send search-button enable on?)
|
|
(send search-menu enable on?))))
|
|
(parent field-panel))))
|
|
|
|
;; exposed to derived classes
|
|
(define stupid-internal-define-syntax6
|
|
(set! choices-panel (instantiate horizontal-panel% ()
|
|
(parent search-panel)
|
|
(alignment '(center center)))))
|
|
|
|
(define search-button (instantiate button% ()
|
|
(label (string-constant plt:hd:search))
|
|
(parent field-panel)
|
|
(callback (lambda (x y) (search-callback #f)))
|
|
(style '(border))))
|
|
(define search-where (instantiate choice% ()
|
|
(label #f)
|
|
(parent choices-panel)
|
|
(selection (preferences:get 'drscheme:help-desk:search-where))
|
|
(choices
|
|
(list
|
|
(string-constant plt:hd:search-for-keyword)
|
|
(string-constant plt:hd:search-for-keyword-or-index)
|
|
(string-constant plt:hd:search-for-keyword-or-index-or-text)))
|
|
(callback
|
|
(lambda (x y)
|
|
(preferences:set 'drscheme:help-desk:search-where
|
|
(send search-where get-selection))))))
|
|
(define search-how (instantiate choice% ()
|
|
(label #f)
|
|
(parent choices-panel)
|
|
(selection (preferences:get 'drscheme:help-desk:search-how))
|
|
(choices
|
|
(list
|
|
(string-constant plt:hd:exact-match)
|
|
(string-constant plt:hd:containing-match)
|
|
(string-constant plt:hd:regexp-match)))
|
|
(callback
|
|
(lambda (x y)
|
|
(preferences:set 'drscheme:help-desk:search-how
|
|
(send search-how get-selection))))))
|
|
|
|
(define grow-box-spacer (make-object grow-box-spacer-pane% choices-panel))
|
|
(define (search-callback lucky?)
|
|
(let-values ([(manuals doc.txt?) (order-manuals (map path->bytes (map car (find-doc-names))))])
|
|
(let ([url (make-results-url
|
|
(send search-field get-value)
|
|
(case (send search-where get-selection)
|
|
[(0) "keyword"]
|
|
[(1) "keyword-index"]
|
|
[(2) "keyword-index-text"])
|
|
(case (send search-how get-selection)
|
|
[(0) "exact-match"]
|
|
[(1) "containing-match"]
|
|
[(2) "regexp-match"])
|
|
lucky?
|
|
(map bytes->path manuals)
|
|
doc.txt?
|
|
(get-language-name))])
|
|
(send (send (get-hyper-panel) get-canvas) goto-url url #f))))
|
|
|
|
(send search-button enable #f)
|
|
(send search-menu enable #f)
|
|
(send search-field focus))))
|
|
|
|
(define help-desk-frame-mixin #f)
|
|
(define addl-mixins (lambda (x) x))
|
|
(define (add-help-desk-mixin m)
|
|
(if help-desk-frame-mixin
|
|
(error 'add-help-desk-mixin "help desk frame has already been created")
|
|
(set! addl-mixins (compose m addl-mixins))))
|
|
(define (make-help-desk-frame-mixin)
|
|
(or help-desk-frame-mixin
|
|
(begin
|
|
(set! help-desk-frame-mixin
|
|
(compose
|
|
addl-mixins
|
|
(lambda (x) (class* x (help-desk-frame<%>) (super-new)))
|
|
make-catch-url-frame-mixin
|
|
bug-report/help-desk-mixin
|
|
make-help-desk-framework-mixin
|
|
browser-scroll-frame-mixin
|
|
frame:searchable-mixin
|
|
frame:standard-menus-mixin
|
|
make-search-button-mixin))
|
|
help-desk-frame-mixin)))
|
|
|
|
(define new-help-desk
|
|
(opt-lambda ([link home-page-url])
|
|
(let ([f (new ((make-help-desk-frame-mixin) hyper-no-show-frame%))])
|
|
(send f show #t)
|
|
(goto-url link f)
|
|
f)))
|
|
|
|
(define (goto-hd-location sym)
|
|
(let ([loc (get-hd-location sym)])
|
|
(goto-url loc)))
|
|
|
|
(define (goto-manual-link manual index-key)
|
|
(goto-url (prefix-with-server (finddoc-page-anchor manual index-key))))
|
|
|
|
(define (search-for-docs search-string search-type match-type lucky? docs)
|
|
(let ([fr (or (find-help-desk-frame)
|
|
(new-help-desk))])
|
|
(search-for-docs/in-frame fr search-string search-type match-type lucky? docs)))
|
|
|
|
(define (search-for-docs/in-frame fr search-string search-type match-type lucky? docs)
|
|
(send fr show #t)
|
|
(let-values ([(manuals doc.txt?) (send fr order-manuals (map path->bytes docs))])
|
|
(goto-url (make-results-url search-string
|
|
search-type
|
|
match-type
|
|
lucky?
|
|
(map bytes->path manuals)
|
|
doc.txt?
|
|
(send fr get-language-name))
|
|
fr)))
|
|
|
|
(define goto-url
|
|
(opt-lambda (link [fr (find-help-desk-frame)])
|
|
(if fr
|
|
(send (send (send fr get-hyper-panel) get-canvas) goto-url link #f)
|
|
(new-help-desk link))))
|
|
|
|
(define (show-help-desk)
|
|
(let ([fr (find-help-desk-frame)])
|
|
(if fr
|
|
(send fr show #t)
|
|
(new-help-desk))))
|
|
|
|
(define (find-help-desk-frame)
|
|
(let loop ([frames (send (group:get-the-frame-group) get-frames)])
|
|
(cond
|
|
[(null? frames) #f]
|
|
[else (let ([frame (car frames)])
|
|
(if (is-a? frame help-desk-frame<%>)
|
|
frame
|
|
(loop (cdr frames))))])))
|
|
|
|
(define (get-url-from-user parent)
|
|
(define d (make-object dialog% (string-constant open-url) parent 500))
|
|
(define t
|
|
(keymap:call/text-keymap-initializer
|
|
(lambda ()
|
|
(make-object text-field% (string-constant url:) d
|
|
(lambda (t e)
|
|
(update-ok))))))
|
|
(define p (make-object horizontal-panel% d))
|
|
(define browse (make-object button% (string-constant browse...) p
|
|
(lambda (b e)
|
|
(let ([f (get-file)])
|
|
(when f
|
|
(send t set-value (encode-file-path-as-url f))
|
|
(update-ok))))))
|
|
|
|
(define (encode-file-path-as-url f)
|
|
(apply
|
|
string-append
|
|
"file:"
|
|
(map
|
|
(λ (x) (string-append "/" (uri-path-segment-encode (path->string x))))
|
|
(explode-path f))))
|
|
|
|
(define spacer (make-object vertical-pane% p))
|
|
(define result #f)
|
|
(define (ok-callback b e)
|
|
(let* ([s (send t get-value)]
|
|
[done (lambda ()
|
|
;; Might be called twice!
|
|
(preferences:set 'drscheme:help-desk:last-url-string s)
|
|
(send d show #f))])
|
|
(with-handlers ([exn:fail?
|
|
(lambda (x)
|
|
(message-box (string-constant bad-url)
|
|
(format (string-constant bad-url:this)
|
|
(exn-message x))
|
|
d))])
|
|
(let* ([removed-spaces (regexp-replace #rx"^[ \t]*" s "")]
|
|
[str (cond
|
|
[(regexp-match #rx":" removed-spaces) removed-spaces]
|
|
[(regexp-match #rx"^[a-zA-Z][a-zA-Z.]*($|/)" removed-spaces)
|
|
(string-append "http://" removed-spaces)]
|
|
[else
|
|
(string-append "file:" removed-spaces)])]
|
|
|
|
;; just convert the string to test it out; don't use result...
|
|
[url (string->url str)])
|
|
(set! result str)
|
|
(done)))))
|
|
(define cancel-callback (lambda (b e) (send d show #f)))
|
|
(define-values (ok cancel)
|
|
(gui-utils:ok/cancel-buttons
|
|
p
|
|
ok-callback
|
|
cancel-callback))
|
|
(define (update-ok)
|
|
(send ok enable
|
|
(positive? (send (send t get-editor)
|
|
last-position))))
|
|
(define last-url-string (preferences:get 'drscheme:help-desk:last-url-string))
|
|
(when last-url-string
|
|
(send t set-value last-url-string)
|
|
(let ([text (send t get-editor)])
|
|
(send text set-position 0 (send text last-position))))
|
|
(send p set-alignment 'right 'center)
|
|
(update-ok)
|
|
(send d center)
|
|
(send t focus)
|
|
(send d show #t)
|
|
result))
|