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

get-diplay-size' and get-display-left-top-inset' use #f for failure

Browse Source 
Since the number of monitors can change at any time, reliable
use of these functions requires handling failure in some way.
Handling #f results is easier (and less likely to mask other
problems) than catching exceptions.

original commit: ce4705cedce9dc6f1658e93245d07f739e26a19b
This commit is contained in:
Matthew Flatt 2011-09-09 09:16:58 -06:00
commit cf84b6b496
31 changed files with 612 additions and 391 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
collects/framework/main.rkt
View File

@ -9,7 +9,12 @@
framework/framework-unit framework/framework-unit
framework/private/sig framework/private/sig
(for-syntax scheme/base) (for-syntax scheme/base)
scribble/srcdoc) scribble/srcdoc)
;; these next two lines do a little dance to make the
;; require/doc setup work out properly
(require (prefix-in :: framework/private/focus-table))
(define frame:lookup-focus-table ::frame:lookup-focus-table)
(require framework/preferences (require framework/preferences
framework/test framework/test
@ -709,7 +714,24 @@
@racket[bitmap% get-loaded-mask]) and @racket['large].}] @racket[bitmap% get-loaded-mask]) and @racket['large].}]
Defaults to @racket[#f].}) Defaults to @racket[#f].})
(proc-doc/names
frame:lookup-focus-table
(->* () (eventspace?) (listof (is-a?/c frame:focus-table<%>)))
(()
((eventspace (current-eventspace))))
@{Returns a list of the frames in @racket[eventspace], where the first element of the list
is the frame with the focus.
The order and contents of the list are maintained by
the methods in @racket[frame:focus-table-mixin], meaning that the
OS-level callbacks that track the focus of individual frames is
ignored.
See also @racket[test:use-focus-table] and @racket[test:get-active-top-level-window].
})
(proc-doc/names (proc-doc/names
group:get-the-frame-group group:get-the-frame-group
(-> (is-a?/c group:%)) (-> (is-a?/c group:%))

3
collects/framework/private/color.rkt
View File

@ -638,7 +638,8 @@ added get-regions
(if (is-a? color color%) (if (is-a? color color%)
color color
(if color mismatch-color (get-match-color))) (if color mismatch-color (get-match-color)))
(= caret-pos (+ start-pos start)))]) (= caret-pos (+ start-pos start))
'low)])
(set! clear-old-locations (set! clear-old-locations
(let ([old clear-old-locations]) (let ([old clear-old-locations])
(λ () (λ ()

12
collects/framework/private/finder.rkt
View File

@ -1,14 +1,15 @@
#lang scheme/unit #lang scheme/unit
(require string-constants (require string-constants
(prefix-in r: racket/gui/base)
"sig.rkt" "sig.rkt"
"../preferences.rkt" "../preferences.rkt"
mred/mred-sig mred/mred-sig
scheme/path) scheme/path)
(import mred^ (import mred^
[prefix keymap: framework:keymap^]) [prefix keymap: framework:keymap^]
[prefix frame: framework:frame^])
(export (rename framework:finder^ (export (rename framework:finder^
[-put-file put-file] [-put-file put-file]
@ -44,7 +45,8 @@
[name (or (and (string? name) (file-name-from-path name)) [name (or (and (string? name) (file-name-from-path name))
name)] name)]
[f (put-file prompt parent-win directory name [f (put-file prompt parent-win directory name
(default-extension) style (default-filters))]) (default-extension) style (default-filters)
#:dialog-mixin frame:focus-table-mixin)])
(and f (or (not filter) (filter-match? filter f filter-msg)) (and f (or (not filter) (filter-match? filter f filter-msg))
(let* ([f (normal-case-path (simple-form-path f))] (let* ([f (normal-case-path (simple-form-path f))]
[dir (path-only f)] [dir (path-only f)]
@ -60,6 +62,7 @@
#f] #f]
[else f])))))) [else f]))))))
(define op (current-output-port))
(define (*get-file style) (define (*get-file style)
(lambda ([directory #f] (lambda ([directory #f]
[prompt (string-constant select-file)] [prompt (string-constant select-file)]
@ -67,7 +70,8 @@
[filter-msg (string-constant file-wrong-form)] [filter-msg (string-constant file-wrong-form)]
[parent-win (dialog-parent-parameter)]) [parent-win (dialog-parent-parameter)])
(let ([f (get-file prompt parent-win directory #f (let ([f (get-file prompt parent-win directory #f
(default-extension) style (default-filters))]) (default-extension) style (default-filters)
#:dialog-mixin frame:focus-table-mixin)])
(and f (or (not filter) (filter-match? filter f filter-msg)) (and f (or (not filter) (filter-match? filter f filter-msg))
(cond [(directory-exists? f) (cond [(directory-exists? f)
(message-box (string-constant error) (message-box (string-constant error)

13
collects/framework/private/focus-table.rkt Normal file
View File

@ -0,0 +1,13 @@
#lang racket/base
(require racket/gui/base racket/class)
(provide frame:lookup-focus-table
frame:set-focus-table)
;; focus-table : hash[eventspace -o> (listof frame)]
(define focus-table (make-hash))
(define (frame:lookup-focus-table [eventspace (current-eventspace)])
(hash-ref focus-table eventspace '()))
(define (frame:set-focus-table eventspace new)
(if (null? new)
(hash-remove! focus-table eventspace)
(hash-set! focus-table eventspace new)))

34
collects/framework/private/frame.rkt
View File

@ -9,6 +9,7 @@
"../preferences.rkt" "../preferences.rkt"
"../gui-utils.rkt" "../gui-utils.rkt"
"bday.rkt" "bday.rkt"
framework/private/focus-table
mrlib/close-icon mrlib/close-icon
mred/mred-sig mred/mred-sig
scheme/path) scheme/path)
@ -131,6 +132,26 @@
editing-this-file? editing-this-file?
get-filename get-filename
make-visible)) make-visible))
(define focus-table<%> (interface (top-level-window<%>)))
(define focus-table-mixin
(mixin (top-level-window<%>) (focus-table<%>)
(inherit get-eventspace)
(define/override (show on?)
(define old (remove this (frame:lookup-focus-table (get-eventspace))))
(define new (if on? (cons this old) old))
(frame:set-focus-table (get-eventspace) new)
(super show on?))
(define/augment (on-close)
(frame:set-focus-table (get-eventspace) (remove this (frame:lookup-focus-table (get-eventspace))))
(inner (void) on-close))
(super-new)
(frame:set-focus-table (get-eventspace) (frame:lookup-focus-table (get-eventspace)))))
(define basic-mixin (define basic-mixin
(mixin ((class->interface frame%)) (basic<%>) (mixin ((class->interface frame%)) (basic<%>)
@ -190,12 +211,11 @@
(λ (% parent) (λ (% parent)
(make-object % parent))) (make-object % parent)))
(inherit can-close? on-close) (inherit on-close can-close?)
(define/public close (define/public (close)
(λ () (when (can-close?)
(when (can-close?) (on-close)
(on-close) (show #f)))
(show #f))))
(inherit accept-drop-files) (inherit accept-drop-files)
@ -2710,7 +2730,7 @@
(min-width (+ (inexact->exact (ceiling indicator-width)) 4)) (min-width (+ (inexact->exact (ceiling indicator-width)) 4))
(min-height (+ (inexact->exact (ceiling indicator-height)) 4)))) (min-height (+ (inexact->exact (ceiling indicator-height)) 4))))
(define basic% (register-group-mixin (basic-mixin frame%))) (define basic% (focus-table-mixin (register-group-mixin (basic-mixin frame%))))
(define size-pref% (size-pref-mixin basic%)) (define size-pref% (size-pref-mixin basic%))
(define info% (info-mixin basic%)) (define info% (info-mixin basic%))
(define text-info% (text-info-mixin info%)) (define text-info% (text-info-mixin info%))

57
collects/framework/private/handler.rkt
View File

@ -120,25 +120,29 @@
;; add-to-recent : path -> void ;; add-to-recent : path -> void
(define (add-to-recent filename) (define (add-to-recent filename)
(let* ([old-list (preferences:get 'framework:recently-opened-files/pos)]
[old-ents (filter (λ (x) (string=? (path->string (car x)) (define old-list (preferences:get 'framework:recently-opened-files/pos))
(path->string filename))) (define old-ents (filter (λ (x) (recently-opened-files-same-enough-path? (car x) filename))
old-list)] old-list))
[old-ent (if (null? old-ents) (define new-ent (if (null? old-ents)
#f (list filename 0 0)
(car old-ents))] (cons filename (cdr (car old-ents)))))
[new-ent (list filename (define added-in (cons new-ent
(if old-ent (cadr old-ent) 0) (remove* (list new-ent)
(if old-ent (caddr old-ent) 0))] old-list
[added-in (cons new-ent (λ (l1 l2)
(remove new-ent old-list compare-recent-list-items))] (recently-opened-files-same-enough-path? (car l1) (car l2))))))
[new-recent (size-down added-in (define new-recent (size-down added-in
(preferences:get 'framework:recent-max-count))]) (preferences:get 'framework:recent-max-count)))
(preferences:set 'framework:recently-opened-files/pos new-recent))) (preferences:set 'framework:recently-opened-files/pos new-recent))
;; same-enough-path? : path path -> boolean
;; used to determine if the open-recent-files menu item considers two paths to be the same
(define (recently-opened-files-same-enough-path? p1 p2)
(equal? (simplify-path (normal-case-path p1) #f)
(simplify-path (normal-case-path p2) #f)))
;; compare-recent-list-items : recent-list-item recent-list-item -> boolean
(define (compare-recent-list-items l1 l2)
(equal? (car l1) (car l2)))
;; size-down : (listof X) -> (listof X)[< recent-max-count] ;; size-down : (listof X) -> (listof X)[< recent-max-count]
;; takes a list of stuff and returns the ;; takes a list of stuff and returns the
@ -167,8 +171,8 @@
(preferences:get 'framework:recently-opened-files/pos)] (preferences:get 'framework:recently-opened-files/pos)]
[new-recent-items [new-recent-items
(map (λ (x) (map (λ (x)
(if (string=? (path->string (car x)) (if (recently-opened-files-same-enough-path? (path->string (car x))
(path->string filename)) (path->string filename))
(list* (car x) start end (cdddr x)) (list* (car x) start end (cdddr x))
x)) x))
(preferences:get 'framework:recently-opened-files/pos))]) (preferences:get 'framework:recently-opened-files/pos))])
@ -198,9 +202,8 @@
(define (recent-list-item->menu-label recent-list-item) (define (recent-list-item->menu-label recent-list-item)
(let ([filename (car recent-list-item)]) (let ([filename (car recent-list-item)])
(gui-utils:trim-string (gui-utils:quote-literal-label
(regexp-replace* #rx"&" (path->string filename) "\\&\\&") (path->string filename))))
200)))
;; this function must mimic what happens in install-recent-items ;; this function must mimic what happens in install-recent-items
;; it returns #t if all of the labels of menus are the same, or approximation to ;; it returns #t if all of the labels of menus are the same, or approximation to
@ -232,8 +235,12 @@
(send ed set-position start end)))))] (send ed set-position start end)))))]
[else [else
(preferences:set 'framework:recently-opened-files/pos (preferences:set 'framework:recently-opened-files/pos
(remove recent-list-item (remove* (list recent-list-item)
(preferences:get 'framework:recently-opened-files/pos))) (preferences:get 'framework:recently-opened-files/pos)
(λ (l1 l2)
(recently-opened-files-same-enough-path?
(car l1)
(car l2)))))
(message-box (string-constant error) (message-box (string-constant error)
(format (string-constant cannot-open-because-dne) (format (string-constant cannot-open-because-dne)
filename))]))) filename))])))

2
collects/framework/private/sig.rkt
View File

@ -256,6 +256,7 @@
(define-signature frame-class^ (define-signature frame-class^
(basic<%> (basic<%>
focus-table<%>
size-pref<%> size-pref<%>
register-group<%> register-group<%>
status-line<%> status-line<%>
@ -285,6 +286,7 @@
delegate% delegate%
pasteboard% pasteboard%
focus-table-mixin
basic-mixin basic-mixin
size-pref-mixin size-pref-mixin
register-group-mixin register-group-mixin

8
collects/framework/private/standard-menus-items.rkt
View File

@ -265,7 +265,9 @@
'(λ (item control) (when (can-close?) (on-close) (show #f)) #t) '(λ (item control) (when (can-close?) (on-close) (show #f)) #t)
#\w #\w
'(get-default-shortcut-prefix) '(get-default-shortcut-prefix)
'(string-constant close-menu-item) '(if (eq? (system-type) 'unix)
(string-constant close-menu-item)
(string-constant close-window-menu-item))
on-demand-do-nothing on-demand-do-nothing
#t) #t)
(make-between 'file-menu 'close 'quit 'nothing) (make-between 'file-menu 'close 'quit 'nothing)
@ -387,8 +389,8 @@
(make-an-item 'edit-menu 'replace (make-an-item 'edit-menu 'replace
'(string-constant replace-info) '(string-constant replace-info)
'(λ (item control) (void)) '(λ (item control) (void))
#\r #\f
'(get-default-shortcut-prefix) '(cons 'shift (get-default-shortcut-prefix))
'(string-constant replace-menu-item) '(string-constant replace-menu-item)
on-demand-do-nothing on-demand-do-nothing
#f) #f)

98
collects/framework/test.rkt
View File

@ -1,10 +1,12 @@
#lang at-exp scheme/gui #lang at-exp scheme/gui
(require scribble/srcdoc) (require scribble/srcdoc
(require/doc scheme/base scribble/manual) (prefix-in :: framework/private/focus-table))
(require/doc scheme/base scribble/manual
(for-label framework))
(define (test:top-level-focus-window-has? pred) (define (test:top-level-focus-window-has? pred)
(let ([tlw (get-top-level-focus-window)]) (let ([tlw (test:get-active-top-level-window)])
(and tlw (and tlw
(let loop ([tlw tlw]) (let loop ([tlw tlw])
(or (pred tlw) (or (pred tlw)
@ -165,16 +167,30 @@
(define current-get-eventspaces (define current-get-eventspaces
(make-parameter (λ () (list (current-eventspace))))) (make-parameter (λ () (list (current-eventspace)))))
(define (get-active-frame) (define test:use-focus-table (make-parameter #f))
(define (test:get-active-top-level-window)
(ormap (λ (eventspace) (ormap (λ (eventspace)
(parameterize ([current-eventspace eventspace]) (parameterize ([current-eventspace eventspace])
(get-top-level-focus-window))) (cond
[(test:use-focus-table)
(define lst (::frame:lookup-focus-table))
(define focusd (and (not (null? lst)) (car lst)))
(when (eq? (test:use-focus-table) 'debug)
(define f2 (get-top-level-focus-window))
(unless (eq? focusd f2)
(eprintf "found mismatch focus-table: ~s vs get-top-level-focus-window: ~s\n"
(map (λ (x) (send x get-label)) lst)
(and f2 (list (send f2 get-label))))))
focusd]
[else
(get-top-level-focus-window)])))
((current-get-eventspaces)))) ((current-get-eventspaces))))
(define (get-focused-window) (define (get-focused-window)
(let ([f (get-active-frame)]) (let ([f (test:get-active-top-level-window)])
(and f (and f
(send f get-focus-window)))) (send f get-edit-target-window))))
(define time-stamp current-milliseconds) (define time-stamp current-milliseconds)
@ -200,14 +216,13 @@
;; get-parent returns () for no parent. ;; get-parent returns () for no parent.
;; ;;
(define in-active-frame? (define (in-active-frame? window)
(λ (window) (let ([frame (test:get-active-top-level-window)])
(let ([frame (get-active-frame)]) (let loop ([window window])
(let loop ([window window]) (cond [(not window) #f]
(cond [(not window) #f] [(null? window) #f] ;; is this test needed?
[(null? window) #f] ;; is this test needed? [(eq? window frame) #t]
[(eq? window frame) #t] [else (loop (send window get-parent))]))))
[else (loop (send window get-parent))])))))
;; ;;
;; Verify modifier list. ;; Verify modifier list.
@ -239,7 +254,7 @@
(cond (cond
[(or (string? b-desc) [(or (string? b-desc)
(procedure? b-desc)) (procedure? b-desc))
(let* ([active-frame (get-active-frame)] (let* ([active-frame (test:get-active-top-level-window)]
[_ (unless active-frame [_ (unless active-frame
(error object-tag (error object-tag
"could not find object: ~a, no active frame" "could not find object: ~a, no active frame"
@ -516,7 +531,7 @@
[else [else
(error (error
key-tag key-tag
"focused window is not a text-field% and does not have on-char")])] "focused window is not a text-field% and does not have on-char, ~e" window)])]
[(send (car l) on-subwindow-char window event) #f] [(send (car l) on-subwindow-char window event) #f]
[else (loop (cdr l))]))) [else (loop (cdr l))])))
@ -573,21 +588,20 @@
(define menu-tag 'test:menu-select) (define menu-tag 'test:menu-select)
(define menu-select (define (menu-select menu-name . item-names)
(λ (menu-name . item-names) (cond
(cond [(not (string? menu-name))
[(not (string? menu-name)) (error menu-tag "expects string, given: ~e" menu-name)]
(error menu-tag "expects string, given: ~e" menu-name)] [(not (andmap string? item-names))
[(not (andmap string? item-names)) (error menu-tag "expects strings, given: ~e" item-names)]
(error menu-tag "expects strings, given: ~e" item-names)] [else
[else (run-one
(run-one (λ ()
(λ () (let* ([frame (test:get-active-top-level-window)]
(let* ([frame (get-active-frame)] [item (get-menu-item frame (cons menu-name item-names))]
[item (get-menu-item frame (cons menu-name item-names))] [evt (make-object control-event% 'menu)])
[evt (make-object control-event% 'menu)]) (send evt set-time-stamp (current-milliseconds))
(send evt set-time-stamp (current-milliseconds)) (send item command evt))))]))
(send item command evt))))])))
(define get-menu-item (define get-menu-item
(λ (frame item-names) (λ (frame item-names)
@ -1021,7 +1035,7 @@
test:top-level-focus-window-has? test:top-level-focus-window-has?
(-> (-> (is-a?/c area<%>) boolean?) boolean?) (-> (-> (is-a?/c area<%>) boolean?) boolean?)
(test) (test)
@{Calls @racket[test] for each child of the top-level-focus-frame @{Calls @racket[test] for each child of the @racket[test:get-active-top-level-window]
and returns @racket[#t] if @racket[test] ever does, otherwise and returns @racket[#t] if @racket[test] ever does, otherwise
returns @racket[#f]. If there returns @racket[#f]. If there
is no top-level-focus-window, returns @racket[#f].}) is no top-level-focus-window, returns @racket[#f].})
@ -1041,4 +1055,20 @@
test:run-one test:run-one
(-> (-> void?) void?) (-> (-> void?) void?)
(f) (f)
@{Runs the function @racket[f] as if it was a simulated event.})) @{Runs the function @racket[f] as if it was a simulated event.})
(parameter-doc
test:use-focus-table
(parameter/c (or/c boolean? 'debug))
use-focus-table?
@{If @racket[#t], then the test framework uses @racket[frame:lookup-focus-table] to determine
which is the focused frame. If @racket[#f], then it uses @racket[get-top-level-focus-window].
If @racket[test:use-focus-table]'s value is @racket['debug], then it still uses
@racket[frame:lookup-focus-table] but it also prints a message to the @racket[current-error-port]
when the two methods would give different results.})
(proc-doc/names
test:get-active-top-level-window
(-> (or/c (is-a?/c frame%) (is-a?/c dialog%) #f))
()
@{Returns the frontmost frame, based on @racket[test:use-focus-table].}))

175
collects/mred/private/filedialog.rkt
View File

@ -1,97 +1,94 @@
(module filedialog mzscheme #lang racket/base
(require mzlib/class (require racket/class
mzlib/etc (prefix-in wx: "kernel.rkt")
mzlib/list (rename-in "wxme/cycle.rkt"
(prefix wx: "kernel.rkt") [set-editor-get-file! wx:set-editor-get-file!]
(prefix wx: racket/snip) [set-editor-put-file! wx:set-editor-put-file!])
(rename "wxme/cycle.rkt" wx:set-editor-get-file! set-editor-get-file!) "lock.rkt"
(rename "wxme/cycle.rkt" wx:set-editor-put-file! set-editor-put-file!) "wx.rkt"
"lock.rkt" "cycle.rkt"
"wx.rkt" "check.rkt"
"cycle.rkt" "mrtop.rkt"
"check.rkt" "path-dialog.rkt")
"mrtop.rkt"
"path-dialog.rkt")
(provide get-file (provide get-file
get-file-list get-file-list
put-file put-file
get-directory) get-directory)
(define (mk-file-selector who put? multi? dir?) (define ((mk-file-selector who put? multi? dir?)
(lambda (message parent directory filename extension style filters) message parent directory filename extension style filters dialog-mixin)
;; Calls from C++ have wrong kind of window: ;; Calls from C++ have wrong kind of window:
(when (is-a? parent wx:window%) (when (is-a? parent wx:window%)
(set! parent (as-entry (lambda () (wx->mred parent))))) (set! parent (as-entry (λ () (wx->mred parent)))))
(check-label-string/false who message)
(check-top-level-parent/false who parent)
(check-path/false who directory)
(check-path/false who filename)
(check-string/false who extension)
(check-style who #f (cond
[dir? '(common enter-packages)]
[else '(common packages enter-packages)]) style)
(unless (and (list? filters)
(andmap (λ (p)
(and (list? p)
(= (length p) 2)
(string? (car p))
(string? (cadr p))))
filters))
(raise-type-error who "list of 2-string lists" filters))
(let* ([std? (memq 'common style)]
[style (if std? (remq 'common style) style)])
(if std?
(send (new (dialog-mixin path-dialog%)
[put? put?]
[dir? dir?]
[multi? multi?]
[message message]
[parent parent]
[directory directory]
[filename filename]
[filters
(cond [(eq? filters default-filters) #t] ; its own defaults
[dir? #f]
[else filters])])
run)
(wx:file-selector
message directory filename extension
;; file types:
filters
;; style:
(cons (cond [dir? 'dir]
[put? 'put]
[multi? 'multi]
[else 'get])
style)
;; parent:
(and parent (mred->wx parent))))))
(check-label-string/false who message) (define default-filters '(("Any" "*.*")))
(check-top-level-parent/false who parent)
(check-path/false who directory)
(check-path/false who filename)
(check-string/false who extension)
(check-style who #f (cond
[dir? '(common enter-packages)]
[else '(common packages enter-packages)]) style)
(unless (and (list? filters)
(andmap (lambda (p)
(and (list? p)
(= (length p) 2)
(string? (car p))
(string? (cadr p))))
filters))
(raise-type-error who "list of 2-string lists" filters))
(let* ([std? (memq 'common style)]
[style (if std? (remq 'common style) style)])
(if std?
(send (new path-dialog%
[put? put?]
[dir? dir?]
[multi? multi?]
[message message]
[parent parent]
[directory directory]
[filename filename]
[filters
(cond [(eq? filters default-filters) #t] ; its own defaults
[dir? #f]
[else filters])])
run)
(wx:file-selector
message directory filename extension
;; file types:
filters
;; style:
(cons (cond [dir? 'dir]
[put? 'put]
[multi? 'multi]
[else 'get])
style)
;; parent:
(and parent (mred->wx parent)))))))
(define default-filters '(("Any" "*.*"))) ;; We duplicate the definition for `get-file', `get-file-list', and
;; `put-file' so that they have the right arities and names
;; We duplicate the case-lambda for `get-file', `get-file-list', and (define-syntax define-file-selector
;; `put-file' so that they have the right arities and names (syntax-rules ()
[(_ name put? multi?)
(define (name [message #f] [parent #f] [directory #f] [filename #f]
[extension #f] [style null] [filters default-filters]
#:dialog-mixin [dialog-mixin values])
((mk-file-selector 'name put? multi? #f)
message parent directory filename extension style filters dialog-mixin))]))
(define-syntax define-file-selector (define-file-selector get-file #f #f)
(syntax-rules () (define-file-selector get-file-list #f #t)
[(_ name put? multi?) (define-file-selector put-file #t #f)
(define name
(opt-lambda ([message #f] [parent #f] [directory #f] [filename #f]
[extension #f] [style null] [filters default-filters])
((mk-file-selector 'name put? multi? #f)
message parent directory filename extension style filters)))]))
(define-file-selector get-file #f #f) (define (get-directory [message #f] [parent #f] [directory #f] [style null] #:dialog-mixin [dialog-mixin values])
(define-file-selector get-file-list #f #t) ((mk-file-selector 'get-directory #f #f #t)
(define-file-selector put-file #t #f) message parent directory #f #f style null dialog-mixin))
(define get-directory (set-get-file! get-file)
(opt-lambda ([message #f] [parent #f] [directory #f] [style null]) (wx:set-editor-get-file! get-file)
((mk-file-selector 'get-directory #f #f #t) (wx:set-editor-put-file! put-file)
message parent directory #f #f style null)))
(set-get-file! get-file)
(wx:set-editor-get-file! get-file)
(wx:set-editor-put-file! put-file))

137
collects/mred/private/messagebox.rkt
View File

@ -1,9 +1,8 @@
(module messagebox mzscheme #lang racket/base
(require mzlib/class (require mzlib/class
mzlib/class100 mzlib/class100
mzlib/etc
mzlib/string mzlib/string
(prefix wx: "kernel.rkt") (prefix-in wx: "kernel.rkt")
"const.rkt" "const.rkt"
"check.rkt" "check.rkt"
"helper.rkt" "helper.rkt"
@ -24,7 +23,8 @@
(lambda (who title message (lambda (who title message
button1 button2 button3 button1 button2 button3
parent style close-result parent style close-result
check? two-results? check-message) check? two-results? check-message
dialog-mixin)
(check-label-string who title) (check-label-string who title)
(check-string/false who message) (check-string/false who message)
(when check? (when check?
@ -46,7 +46,8 @@
who title message who title message
button1 button2 button3 button1 button2 button3
parent style close-result parent style close-result
check? two-results? check-message))] check? two-results? check-message
dialog-mixin))]
[es (if parent [es (if parent
(send parent get-eventspace) (send parent get-eventspace)
(wx:current-eventspace))]) (wx:current-eventspace))])
@ -65,51 +66,53 @@
(lambda (who title message (lambda (who title message
button1 button2 button3 button1 button2 button3
parent style close-result parent style close-result
check? two-results? check-message) check? two-results? check-message
dialog-mixin)
(let* ([strings (regexp-split #rx"\n" message)] (let* ([strings (regexp-split #rx"\n" message)]
[single? (and (< (length strings) 10) [single? (and (< (length strings) 10)
(andmap (lambda (s) (< (string-length s) 60)) strings))] (andmap (lambda (s) (< (string-length s) 60)) strings))]
[f (make-object (class100 dialog% () [f (make-object (dialog-mixin
(public (class100 dialog% ()
[get-message (public
(lambda () message)]) [get-message
(augment (lambda () message)])
[can-close? (lambda () (augment
(if (memq 'disallow-close style) [can-close? (lambda ()
(begin (if (memq 'disallow-close style)
(wx:bell) (begin
#f) (wx:bell)
#t))]) #f)
(override #t))])
[on-subwindow-event (override
(lambda (w e) [on-subwindow-event
(if (send e button-down?) (lambda (w e)
(if (is-a? w button%) (if (send e button-down?)
#f (if (is-a? w button%)
(if (or (is-a? w message%) #f
(and (if (or (is-a? w message%)
(is-a? w editor-canvas%) (and
(let-values ([(w h) (send w get-client-size)]) (is-a? w editor-canvas%)
(< (send e get-x) w)))) (let-values ([(w h) (send w get-client-size)])
(begin (< (send e get-x) w))))
(send w popup-menu (begin
(let ([m (make-object popup-menu%)]) (send w popup-menu
(make-object menu-item% (let ([m (make-object popup-menu%)])
"Copy Message" (make-object menu-item%
m "Copy Message"
(lambda (i e) m
(send (wx:get-the-clipboard) (lambda (i e)
set-clipboard-string (send (wx:get-the-clipboard)
message set-clipboard-string
(send e get-time-stamp)))) message
m) (send e get-time-stamp))))
(send e get-x) m)
(send e get-y)) (send e get-x)
#t) (send e get-y))
#f)) #t)
#f))]) #f))
(sequence #f))])
(super-init title parent box-width))))] (sequence
(super-init title parent box-width)))))]
[result close-result] [result close-result]
[icon-id (cond [icon-id (cond
[(memq 'stop style) 'stop] [(memq 'stop style) 'stop]
@ -224,20 +227,21 @@
result)))))) result))))))
(define message-box/custom (define message-box/custom
(opt-lambda (title message (lambda (title message
button1 button1
button2 button2
button3 button3
[parent #f] [parent #f]
[style '(no-default)] [style '(no-default)]
[close-result #f]) [close-result #f]
#:dialog-mixin [dialog-mixin values])
(do-message-box/custom 'message-box/custom (do-message-box/custom 'message-box/custom
title message button1 button2 button3 title message button1 button2 button3
parent style close-result parent style close-result
#f #f #f))) #f #f #f dialog-mixin)))
(define do-message-box (define do-message-box
(lambda (who title message parent style check? check-message) (lambda (who title message parent style check? check-message dialog-mixin)
(check-label-string who title) (check-label-string who title)
(check-string/false who message) (check-string/false who message)
(when check? (when check?
@ -276,7 +280,8 @@
(list default) (list default)
(list default 'disallow-close))) (list default 'disallow-close)))
close-val close-val
check? #t check-message)]) check? #t check-message
dialog-mixin)])
(let ([result (case result (let ([result (case result
[(1) one-v] [(1) one-v]
[(2) two-v])]) [(2) two-v])])
@ -285,23 +290,25 @@
result)))))) result))))))
(define message-box (define message-box
(opt-lambda (title message [parent #f] [style '(ok)]) (lambda (title message [parent #f] [style '(ok)] #:dialog-mixin [dialog-mixin values])
(do-message-box 'message-box title message parent style #f #f))) (do-message-box 'message-box title message parent style #f #f dialog-mixin)))
(define message+check-box/custom (define message+check-box/custom
(opt-lambda (title message (lambda (title message
checkbox-message checkbox-message
button1 button1
button2 button2
button3 button3
[parent #f] [parent #f]
[style '(no-default)] [style '(no-default)]
[close-result #f]) [close-result #f]
#:dialog-mixin [dialog-mixin values])
(do-message-box/custom 'message+check-box/custom (do-message-box/custom 'message+check-box/custom
title message button1 button2 button3 title message button1 button2 button3
parent style close-result parent style close-result
#t #t checkbox-message))) #t #t checkbox-message
dialog-mixin)))
(define message+check-box (define message+check-box
(opt-lambda (title message check-message [parent #f] [style '(ok)]) (lambda (title message check-message [parent #f] [style '(ok)] #:dialog-mixin [dialog-mixin values])
(do-message-box 'message-box title message parent style #t check-message)))) (do-message-box 'message-box title message parent style #t check-message dialog-mixin)))

70
collects/mred/private/moredialogs.rkt
View File

@ -1,19 +1,14 @@
(module moredialogs mzscheme #lang racket/base
(require mzlib/class (require racket/class
mzlib/etc (prefix-in wx: "kernel.rkt")
mzlib/list (prefix-in wx: racket/snip)
(prefix wx: "kernel.rkt")
(prefix wx: racket/snip)
"lock.rkt" "lock.rkt"
"const.rkt" "const.rkt"
"check.rkt" "check.rkt"
"wx.rkt" "wx.rkt"
"helper.rkt" "helper.rkt"
"editor.rkt"
"mrtop.rkt" "mrtop.rkt"
"mrcanvas.rkt" "mrcanvas.rkt"
"mrpopup.rkt"
"mrmenu.rkt"
"mritem.rkt" "mritem.rkt"
"mrpanel.rkt" "mrpanel.rkt"
"mrtextfield.rkt") "mrtextfield.rkt")
@ -190,34 +185,33 @@
(define (can-get-page-setup-from-user?) (define (can-get-page-setup-from-user?)
(wx:can-show-print-setup?)) (wx:can-show-print-setup?))
(define get-text-from-user (define (get-text-from-user title message
(case-lambda [parent #f]
[(title message) (get-text-from-user title message #f "" null)] [init-val ""]
[(title message parent) (get-text-from-user title message parent "" null)] [style null]
[(title message parent init-val) (get-text-from-user title message parent init-val null)] #:dialog-mixin [dialog-mixin values])
[(title message parent init-val style) (check-label-string 'get-text-from-user title)
(check-label-string 'get-text-from-user title) (check-label-string/false 'get-text-from-user message)
(check-label-string/false 'get-text-from-user message) (check-top-level-parent/false 'get-text-from-user parent)
(check-top-level-parent/false 'get-text-from-user parent) (check-string 'get-text-from-user init-val)
(check-string 'get-text-from-user init-val) (check-style 'get-text-from-user #f '(password) style)
(check-style 'get-text-from-user #f '(password) style) (define f (make-object (dialog-mixin dialog%) title parent box-width))
(let* ([f (make-object dialog% title parent box-width)] (define ok? #f)
[ok? #f] (define ((done ?) b e) (set! ok? ?) (send f show #f))
[done (lambda (?) (lambda (b e) (set! ok? ?) (send f show #f)))]) (define t (make-object text-field% message f (lambda (t e) (when (eq? (send e get-event-type) 'text-field-enter)
(let ([t (make-object text-field% message f (lambda (t e) (when (eq? (send e get-event-type) 'text-field-enter) ((done #t) #f #f)))
((done #t) #f #f))) init-val (list* 'single 'vertical-label style)))
init-val (list* 'single 'vertical-label style))] (define p (make-object horizontal-pane% f))
[p (make-object horizontal-pane% f)]) (send p set-alignment 'right 'center)
(send p set-alignment 'right 'center) (send f stretchable-height #f)
(send f stretchable-height #f) (ok-cancel
(ok-cancel (lambda () (make-object button% "OK" p (done #t) '(border)))
(lambda () (make-object button% "OK" p (done #t) '(border))) (lambda () (make-object button% "Cancel" p (done #f))))
(lambda () (make-object button% "Cancel" p (done #f)))) (send (send t get-editor) select-all)
(send (send t get-editor) select-all) (send t focus)
(send t focus) (send f center)
(send f center) (send f show #t)
(send f show #t) (and ok? (send t get-value)))
(and ok? (send t get-value))))]))
(define get-choices-from-user (define get-choices-from-user
(case-lambda (case-lambda
@ -347,4 +341,4 @@
(send f center) (send f center)
(send f show #t) (send f show #t)
(and ok? (and ok?
(get-current-color))))]))) (get-current-color))))]))

16
collects/mred/private/wx/cocoa/frame.rkt
View File

@ -86,6 +86,19 @@
(when wxb (when wxb
(let ([wx (->wx wxb)]) (let ([wx (->wx wxb)])
(when wx (when wx
;; Sometimes, a sheet becomes the main window and the parent
;; still thinks that the parent is the main window. Tell
;; the parent otherwise.
(let ([p (send wx get-parent)])
(when p
(let ([s (send p get-sheet)])
(when (eq? s wx)
(let ([parent (send p get-cocoa)])
(when (tell #:type _BOOL parent isMainWindow)
;; The Cocoa docs say never to call this method directly,
;; but we're trying to fix up a case where Cocoa seems
;; to be confused:
(tellv parent resignMainWindow)))))))
(set! front wx) (set! front wx)
(send wx install-wait-cursor) (send wx install-wait-cursor)
(send wx install-mb) (send wx install-mb)
@ -344,7 +357,8 @@
(define/public (force-window-focus) (define/public (force-window-focus)
(let ([next (get-app-front-window)]) (let ([next (get-app-front-window)])
(cond (cond
[next (tellv next makeKeyWindow)] [next
(tellv next makeKeyWindow)]
[root-fake-frame [root-fake-frame
;; Make key focus shift to root frame: ;; Make key focus shift to root frame:
(let ([root-cocoa (send root-fake-frame get-cocoa)]) (let ([root-cocoa (send root-fake-frame get-cocoa)])

2
collects/mred/private/wx/cocoa/menu-bar.rkt
View File

@ -108,7 +108,7 @@
app)) app))
(tellv apple addItem: item) (tellv apple addItem: item)
(tellv item release)))]) (tellv item release)))])
(std (format "About ~a" app-name) (selector orderFrontStandardAboutPanel:)) (std (format "About ~a" app-name) (selector openAbout:) "" #f #t)
(std "Preferences..." (selector openPreferences:) "," #f #t) (std "Preferences..." (selector openPreferences:) "," #f #t)
(tellv apple addItem: (tell NSMenuItem separatorItem)) (tellv apple addItem: (tell NSMenuItem separatorItem))
(let ([services (tell (tell NSMenu alloc) initWithTitle: #:type _NSString "Services")]) (let ([services (tell (tell NSMenu alloc) initWithTitle: #:type _NSString "Services")])

8
collects/mred/private/wx/cocoa/procs.rkt
View File

@ -89,7 +89,7 @@
(define (check-for-break) #f) (define (check-for-break) #f)
(define (display-origin xb yb all? num) (define (display-origin xb yb all? num fail)
(if (or all? (positive? num)) (if (or all? (positive? num))
(unless (atomically (unless (atomically
(with-autorelease (with-autorelease
@ -108,13 +108,13 @@
(NSSize-height (NSRect-size f0))))))) (NSSize-height (NSRect-size f0)))))))
#t) #t)
#f)))) #f))))
(error 'get-display-left-top-inset "no such monitor: ~v" num)) (fail))
(set-box! xb 0)) (set-box! xb 0))
(when (zero? num) (when (zero? num)
(set-box! yb 0)) (set-box! yb 0))
(set-box! yb (+ (unbox yb) (get-menu-bar-height)))) (set-box! yb (+ (unbox yb) (get-menu-bar-height))))
(define (display-size xb yb all? num) (define (display-size xb yb all? num fail)
(unless (atomically (unless (atomically
(with-autorelease (with-autorelease
(let ([screens (tell NSScreen screens)]) (let ([screens (tell NSScreen screens)])
@ -134,7 +134,7 @@
(get-menu-bar-height)])))) (get-menu-bar-height)]))))
#t) #t)
#f)))) #f))))
(error 'get-display-size "no such monitor: ~v" num))) (fail)))
(define (display-count) (define (display-count)

34
collects/mred/private/wx/cocoa/queue.rkt
View File

@ -56,10 +56,21 @@
(queue-prefs-event) (queue-prefs-event)
#t] #t]
[-a _BOOL (validateMenuItem: [_id menuItem]) [-a _BOOL (validateMenuItem: [_id menuItem])
(if (ptr-equal? (selector openPreferences:) (cond
(tell #:type _SEL menuItem action)) [(ptr-equal? (selector openPreferences:)
(not (eq? (application-pref-handler) nothing-application-pref-handler)) (tell #:type _SEL menuItem action))
(super-tell #:type _BOOL validateMenuItem: menuItem))] (not (eq? (application-pref-handler) nothing-application-pref-handler))]
[(ptr-equal? (selector openAbout:)
(tell #:type _SEL menuItem action))
#t]
[else
(super-tell #:type _BOOL validateMenuItem: menuItem)])]
[-a _BOOL (openAbout: [_id sender])
(if (eq? nothing-application-about-handler
(application-about-handler))
(tellv app orderFrontStandardAboutPanel: sender)
(queue-about-event))
#t]
[-a _BOOL (application: [_id theApplication] openFile: [_NSString filename]) [-a _BOOL (application: [_id theApplication] openFile: [_NSString filename])
(queue-file-event (string->path filename))] (queue-file-event (string->path filename))]
[-a _BOOL (applicationShouldHandleReopen: [_id app] hasVisibleWindows: [_BOOL has-visible?]) [-a _BOOL (applicationShouldHandleReopen: [_id app] hasVisibleWindows: [_BOOL has-visible?])
@ -82,15 +93,17 @@
;; explicitly register with the dock so the application can receive ;; explicitly register with the dock so the application can receive
;; keyboard events. ;; keyboard events.
(define-cstruct _ProcessSerialNumber (define-cstruct _ProcessSerialNumber
([highLongOfPSN _ulong] ([highLongOfPSN _uint32]
[lowLongOfPSN _ulong])) [lowLongOfPSN _uint32]))
(define kCurrentProcess 2) (define kCurrentProcess 2)
(define kProcessTransformToForegroundApplication 1) (define kProcessTransformToForegroundApplication 1)
(define-appserv TransformProcessType (_fun _ProcessSerialNumber-pointer (define-appserv TransformProcessType (_fun _ProcessSerialNumber-pointer
_uint32 _uint32
-> _OSStatus)) -> _OSStatus))
(void (TransformProcessType (make-ProcessSerialNumber 0 kCurrentProcess) (let ([v (TransformProcessType (make-ProcessSerialNumber 0 kCurrentProcess)
kProcessTransformToForegroundApplication)) kProcessTransformToForegroundApplication)])
(unless (zero? v)
(log-error (format "error from TransformProcessType: ~a" v))))
(define app-delegate (tell (tell MyApplicationDelegate alloc) init)) (define app-delegate (tell (tell MyApplicationDelegate alloc) init))
(tellv app setDelegate: app-delegate) (tellv app setDelegate: app-delegate)
@ -108,8 +121,9 @@
(define-appserv CGDisplayRegisterReconfigurationCallback (define-appserv CGDisplayRegisterReconfigurationCallback
(_fun (_fun #:atomic? #t -> _void) _pointer -> _int32)) (_fun (_fun #:atomic? #t -> _void) _pointer -> _int32))
(define (on-screen-changed) (post-dummy-event)) (define (on-screen-changed) (post-dummy-event))
(void (let ([v (CGDisplayRegisterReconfigurationCallback on-screen-changed #f)])
(CGDisplayRegisterReconfigurationCallback on-screen-changed #f)) (unless (zero? v)
(log-error (format "error from CGDisplayRegisterReconfigurationCallback: ~a" v))))
(tellv app finishLaunching) (tellv app finishLaunching)

6
collects/mred/private/wx/common/handlers.rkt
View File

@ -6,7 +6,8 @@
application-about-handler application-about-handler
application-pref-handler application-pref-handler
nothing-application-pref-handler)) nothing-application-pref-handler
nothing-application-about-handler))
(define saved-files null) (define saved-files null)
(define afh (lambda (f) (define afh (lambda (f)
@ -26,7 +27,8 @@
[(proc) (set! aqh proc)] [(proc) (set! aqh proc)]
[() aqh])) [() aqh]))
(define aah void) (define (nothing-application-about-handler) (void))
(define aah nothing-application-about-handler)
(define application-about-handler (define application-about-handler
(case-lambda (case-lambda
[(proc) (set! aah proc)] [(proc) (set! aah proc)]

5
collects/mred/private/wx/common/queue.rkt
View File

@ -54,6 +54,7 @@
queue-quit-event queue-quit-event
queue-prefs-event queue-prefs-event
queue-about-event
queue-file-event queue-file-event
begin-busy-cursor begin-busy-cursor
@ -571,6 +572,10 @@
;; called in event-pump thread ;; called in event-pump thread
(queue-event main-eventspace (application-pref-handler) 'med)) (queue-event main-eventspace (application-pref-handler) 'med))
(define (queue-about-event)
;; called in event-pump thread
(queue-event main-eventspace (application-about-handler) 'med))
(define (queue-file-event file) (define (queue-file-event file)
;; called in event-pump thread ;; called in event-pump thread
(queue-event main-eventspace (lambda () (queue-event main-eventspace (lambda ()

3
collects/mred/private/wx/gtk/canvas.rkt
View File

@ -280,7 +280,8 @@
(unless (eq? client-gtk container-gtk) (unless (eq? client-gtk container-gtk)
(gtk_fixed_set_has_window client-gtk #t)) ; imposes clipping (gtk_fixed_set_has_window client-gtk #t)) ; imposes clipping
(when has-border? (when has-border?
(gtk_container_set_border_width h margin)) (gtk_container_set_border_width h margin)
(connect-expose-border h))
(gtk_box_pack_start h v #t #t 0) (gtk_box_pack_start h v #t #t 0)
(gtk_box_pack_start v client-gtk #t #t 0) (gtk_box_pack_start v client-gtk #t #t 0)
(gtk_box_pack_start h v2 #f #f 0) (gtk_box_pack_start h v2 #f #f 0)

14
collects/mred/private/wx/gtk/frame.rkt
View File

@ -265,7 +265,7 @@
(send p get-size sw-box sh-box) (send p get-size sw-box sh-box)
(set-box! sx-box (send p get-x)) (set-box! sx-box (send p get-x))
(set-box! sy-box (send p get-y))) (set-box! sy-box (send p get-y)))
(display-size sw-box sh-box #t 0))) (display-size sw-box sh-box #t 0 void)))
(let* ([sw (unbox sw-box)] (let* ([sw (unbox sw-box)]
[sh (unbox sh-box)] [sh (unbox sh-box)]
[fw (unbox w-box)] [fw (unbox w-box)]
@ -497,21 +497,21 @@
(define-gdk gdk_screen_get_monitor_geometry (_fun _GdkScreen _int _GdkRectangle-pointer -> _void)) (define-gdk gdk_screen_get_monitor_geometry (_fun _GdkScreen _int _GdkRectangle-pointer -> _void))
(define-gdk gdk_screen_get_n_monitors (_fun _GdkScreen -> _int)) (define-gdk gdk_screen_get_n_monitors (_fun _GdkScreen -> _int))
(define (monitor-rect who num) (define (monitor-rect num fail)
(let ([s (gdk_screen_get_default)] (let ([s (gdk_screen_get_default)]
[r (make-GdkRectangle 0 0 0 0)]) [r (make-GdkRectangle 0 0 0 0)])
(unless (num . < . (gdk_screen_get_n_monitors s)) (unless (num . < . (gdk_screen_get_n_monitors s))
(error who "no such monitor: ~v" num)) (fail))
(gdk_screen_get_monitor_geometry s num r) (gdk_screen_get_monitor_geometry s num r)
r)) r))
(define (display-origin x y all? num) (define (display-origin x y all? num fail)
(let ([r (monitor-rect 'get-display-left-top-inset num)]) (let ([r (monitor-rect num fail)])
(set-box! x (- (GdkRectangle-x r))) (set-box! x (- (GdkRectangle-x r)))
(set-box! y (- (GdkRectangle-y r))))) (set-box! y (- (GdkRectangle-y r)))))
(define (display-size w h all? num) (define (display-size w h all? num fail)
(let ([r (monitor-rect 'get-display-size num)]) (let ([r (monitor-rect num fail)])
(set-box! w (GdkRectangle-width r)) (set-box! w (GdkRectangle-width r))
(set-box! h (GdkRectangle-height r)))) (set-box! h (GdkRectangle-height r))))

2
collects/mred/private/wx/gtk/list-box.rkt
View File

@ -211,7 +211,7 @@
[font font] [font font]
[no-show? (memq 'deleted style)]) [no-show? (memq 'deleted style)])
(set-auto-size) (set-auto-size 32) ; 32 is extra width
(connect-changed selection) (connect-changed selection)
(connect-activated client-gtk) (connect-activated client-gtk)

41
collects/mred/private/wx/gtk/menu.rkt
View File

@ -181,25 +181,27 @@
(unless (unbox cnb) (unless (unbox cnb)
(cb this e))))))) (cb this e)))))))
(define/private (adjust-shortcut item-gtk title) (define/private (adjust-shortcut item-gtk title need-clear?)
(let ([m (regexp-match #rx"\t(Ctrl[+])?(Shift[+])?(Meta[+])?(Alt[+])?(.|[0-9]+)$" (let ([m (regexp-match #rx"\t(Ctrl[+])?(Shift[+])?(Meta[+])?(Alt[+])?(.|[0-9]+)$"
title)]) title)])
(when m (if m
(let ([mask (+ (if (list-ref m 1) GDK_CONTROL_MASK 0) (let ([mask (+ (if (list-ref m 1) GDK_CONTROL_MASK 0)
(if (list-ref m 2) GDK_SHIFT_MASK 0) (if (list-ref m 2) GDK_SHIFT_MASK 0)
(if (list-ref m 3) GDK_MOD1_MASK 0) (if (list-ref m 3) GDK_MOD1_MASK 0)
(if (list-ref m 4) GDK_META_MASK 0))] (if (list-ref m 4) GDK_META_MASK 0))]
[code (let ([s (list-ref m 5)]) [code (let ([s (list-ref m 5)])
(if (= 1 (string-length s)) (if (= 1 (string-length s))
(gdk_unicode_to_keyval (gdk_unicode_to_keyval
(char->integer (string-ref s 0))) (char->integer (string-ref s 0)))
(string->number s)))]) (string->number s)))])
(unless (zero? code) (unless (zero? code)
(let ([accel-path (format "<GRacket>/Hardwired/~a" title)]) (let ([accel-path (format "<GRacket>/Hardwired/~a" title)])
(gtk_accel_map_add_entry accel-path (gtk_accel_map_add_entry accel-path
code code
mask) mask)
(gtk_menu_item_set_accel_path item-gtk accel-path))))))) (gtk_menu_item_set_accel_path item-gtk accel-path))))
(when need-clear?
(gtk_menu_item_set_accel_path item-gtk #f)))))
(public [append-item append]) (public [append-item append])
(define (append-item i label help-str-or-submenu chckable?) (define (append-item i label help-str-or-submenu chckable?)
@ -226,7 +228,7 @@
[menu-item i] [menu-item i]
[parent this])]) [parent this])])
(set! items (append items (list (list item item-gtk label chckable?)))) (set! items (append items (list (list item item-gtk label chckable?))))
(adjust-shortcut item-gtk label))) (adjust-shortcut item-gtk label #f)))
(gtk_menu_shell_append gtk item-gtk) (gtk_menu_shell_append gtk item-gtk)
(gtk_widget_show item-gtk)))) (gtk_widget_show item-gtk))))
@ -258,7 +260,8 @@
(let ([gtk (find-gtk item)]) (let ([gtk (find-gtk item)])
(when gtk (when gtk
(gtk_label_set_text_with_mnemonic (gtk_bin_get_child gtk) (gtk_label_set_text_with_mnemonic (gtk_bin_get_child gtk)
(fixup-mnemonic str))))) (fixup-mnemonic str))
(adjust-shortcut gtk str #t))))
(define/public (enable item on?) (define/public (enable item on?)
(let ([gtk (find-gtk item)]) (let ([gtk (find-gtk item)])

18
collects/mred/private/wx/gtk/panel.rkt
View File

@ -35,14 +35,16 @@
[gray #x8000]) [gray #x8000])
(when gc (when gc
(gdk_gc_set_rgb_fg_color gc (make-GdkColor 0 gray gray gray)) (gdk_gc_set_rgb_fg_color gc (make-GdkColor 0 gray gray gray))
(let ([a (widget-allocation gtk)] (let* ([a (widget-allocation gtk)]
[no-window? (not (zero? (bitwise-and (get-gtk-object-flags gtk) [w (sub1 (GtkAllocation-width a))]
GTK_NO_WINDOW)))]) [h (sub1 (GtkAllocation-height a))])
(gdk_draw_rectangle win gc #f (let loop ([gtk gtk] [x 0] [y 0])
(if no-window? (GtkAllocation-x a) 0) (if (not (zero? (bitwise-and (get-gtk-object-flags gtk) GTK_NO_WINDOW)))
(if no-window? (GtkAllocation-y a) 0) ;; no window:
(sub1 (GtkAllocation-width a)) (let ([a (widget-allocation gtk)])
(sub1 (GtkAllocation-height a)))) (loop (widget-parent gtk) (+ x (GtkAllocation-x a)) (+ y (GtkAllocation-y a))))
;; found window:
(gdk_draw_rectangle win gc #f x y w h))))
(gdk_gc_unref gc))) (gdk_gc_unref gc)))
#f)) #f))

10
collects/mred/private/wx/gtk/window.rkt
View File

@ -42,6 +42,7 @@
widget-window widget-window
widget-allocation widget-allocation
widget-parent
the-accelerator-group the-accelerator-group
gtk_window_add_accel_group gtk_window_add_accel_group
@ -105,6 +106,9 @@
(define (widget-window gtk) (define (widget-window gtk)
(GtkWidgetT-window (cast gtk _GtkWidget _GtkWidgetT-pointer))) (GtkWidgetT-window (cast gtk _GtkWidget _GtkWidgetT-pointer)))
(define (widget-parent gtk)
(GtkWidgetT-parent (cast gtk _GtkWidget _GtkWidgetT-pointer)))
(define (widget-allocation gtk) (define (widget-allocation gtk)
(GtkWidgetT-alloc (cast gtk _GtkWidget _GtkWidgetT-pointer))) (GtkWidgetT-alloc (cast gtk _GtkWidget _GtkWidgetT-pointer)))
@ -506,13 +510,13 @@
(set! client-delta-h (- (GtkRequisition-height req) (set! client-delta-h (- (GtkRequisition-height req)
(GtkRequisition-height creq)))))) (GtkRequisition-height creq))))))
(define/public (set-auto-size) (define/public (set-auto-size [dw 0] [dh 0])
(let ([req (make-GtkRequisition 0 0)]) (let ([req (make-GtkRequisition 0 0)])
(gtk_widget_size_request gtk req) (gtk_widget_size_request gtk req)
(set-size -11111 (set-size -11111
-11111 -11111
(GtkRequisition-width req) (+ (GtkRequisition-width req) dw)
(GtkRequisition-height req)))) (+ (GtkRequisition-height req) dh))))
(define shown? #f) (define shown? #f)
(define/public (direct-show on?) (define/public (direct-show on?)

14
collects/mred/private/wx/win32/canvas.rkt
View File

@ -242,7 +242,7 @@
(define/override (on-resized) (define/override (on-resized)
(reset-dc)) (reset-dc))
(define/private (reset-dc) (define/private (reset-dc [refresh? #t])
(send dc reset-backing-retained) (send dc reset-backing-retained)
(send dc set-auto-scroll (send dc set-auto-scroll
(if (get-virtual-width) (if (get-virtual-width)
@ -250,16 +250,8 @@
0) 0)
(if (get-virtual-height) (if (get-virtual-height)
(get-virtual-v-pos) (get-virtual-v-pos)
0))) 0))
(when refresh? (refresh-one)))
(define/public (tell-me-what)
(let ([r (GetClientRect (get-client-hwnd))]
[rr (GetWindowRect (get-hwnd))])
(printf "~s\n"
(list hscroll? vscroll?
(list (RECT-left r) (RECT-top r) (RECT-right r) (RECT-bottom r))
(list (RECT-left rr) (RECT-top rr) (RECT-right rr) (RECT-bottom rr))))))
(define/override (show-children) (define/override (show-children)
(when (dc . is-a? . dc<%>) (when (dc . is-a? . dc<%>)

10
collects/mred/private/wx/win32/frame.rkt
View File

@ -78,12 +78,12 @@
#f) #f)
(reverse rects))) (reverse rects)))
(define (display-size xb yb all? num) (define (display-size xb yb all? num fail)
(cond (cond
[(positive? num) [(positive? num)
(let ([rs (get-all-screen-rects)]) (let ([rs (get-all-screen-rects)])
(unless (num . < . (length rs)) (unless (num . < . (length rs))
(error 'get-display-size "no such monitor: ~v" num)) (fail))
(let ([r (list-ref rs num)]) (let ([r (list-ref rs num)])
(set-box! xb (- (caddr r) (car r))) (set-box! xb (- (caddr r) (car r)))
(set-box! yb (- (cadddr r) (cadr r)))))] (set-box! yb (- (cadddr r) (cadr r)))))]
@ -99,12 +99,12 @@
(set-box! xb (- (RECT-right r) (RECT-left r))) (set-box! xb (- (RECT-right r) (RECT-left r)))
(set-box! yb (- (RECT-bottom r) (RECT-top r))))])) (set-box! yb (- (RECT-bottom r) (RECT-top r))))]))
(define (display-origin xb yb avoid-bars? num) (define (display-origin xb yb avoid-bars? num fail)
(cond (cond
[(positive? num) [(positive? num)
(let ([rs (get-all-screen-rects)]) (let ([rs (get-all-screen-rects)])
(unless (num . < . (length rs)) (unless (num . < . (length rs))
(error 'get-display-left-top-inset "no such monitor: ~v" num)) (fail))
(let ([r (list-ref rs num)]) (let ([r (list-ref rs num)])
(set-box! xb (- (car r))) (set-box! xb (- (car r)))
(set-box! yb (- (cadr r)))))] (set-box! yb (- (cadr r)))))]
@ -435,7 +435,7 @@
[wh (box 0)] [wh (box 0)]
[wx (box 0)] [wx (box 0)]
[wy (box 0)]) [wy (box 0)])
(display-size sw sh #f 0) (display-size sw sh #f 0 void)
(if wrt (if wrt
(begin (begin
(send wrt get-size ww wh) (send wrt get-size ww wh)

19
collects/mred/private/wxtop.rkt
View File

@ -35,19 +35,22 @@
(lambda ([full-screen? #f] #:monitor [monitor 0]) (lambda ([full-screen? #f] #:monitor [monitor 0])
(unless (exact-nonnegative-integer? monitor) (unless (exact-nonnegative-integer? monitor)
(raise-type-error 'get-display-size "exact non-negative integer" monitor)) (raise-type-error 'get-display-size "exact non-negative integer" monitor))
(let ([xb (box 0)] (let/ec esc
[yb (box 0)]) (let ([xb (box 0)]
(wx:display-size xb yb full-screen? monitor) [yb (box 0)])
(values (unbox xb) (unbox yb))))) (wx:display-size xb yb full-screen? monitor
(lambda () (esc #f #f)))
(values (unbox xb) (unbox yb))))))
(define get-display-left-top-inset (define get-display-left-top-inset
(lambda ([advisory? #f] #:monitor [monitor 0]) (lambda ([advisory? #f] #:monitor [monitor 0])
(unless (exact-nonnegative-integer? monitor) (unless (exact-nonnegative-integer? monitor)
(raise-type-error 'get-display-left-top-inset "exact non-negative integer" monitor)) (raise-type-error 'get-display-left-top-inset "exact non-negative integer" monitor))
(let ([xb (box 0)] (let/ec esc
[yb (box 0)]) (let ([xb (box 0)]
(wx:display-origin xb yb advisory? monitor) [yb (box 0)])
(values (unbox xb) (unbox yb))))) (wx:display-origin xb yb advisory? monitor (lambda () (esc #f #f)))
(values (unbox xb) (unbox yb))))))
(define get-display-count (define get-display-count
(lambda () (lambda ()

77
collects/scribblings/framework/frame.scrbl
View File

@ -28,7 +28,9 @@
Return @racket[menu-bar%]. Return @racket[menu-bar%].
} }
@defmethod*[(((make-root-area-container (class (implementation?/c area-container<%>)) (parent (is-a?/c area-container<%>))) (is-a?/c area-container<%>)))]{ @defmethod*[(((make-root-area-container (class (implementation?/c area-container<%>))
(parent (is-a?/c area-container<%>)))
(is-a?/c area-container<%>)))]{
Override this method to insert a panel in between the panel used by Override this method to insert a panel in between the panel used by
the clients of this frame and the frame itself. For example, to insert the clients of this frame and the frame itself. For example, to insert
a status line panel override this method with something like this: a status line panel override this method with something like this:
@ -160,6 +162,35 @@
using the @method[frame:basic<%> make-root-area-container] method). using the @method[frame:basic<%> make-root-area-container] method).
} }
} }
@definterface[frame:focus-table<%> (top-level-window<%>)]{}
@defmixin[frame:focus-table-mixin (frame%) (frame:focus-table<%>)]{
Instances of classes returned from this mixin track how frontmost they are
based on calls made to methods at the Racket level, instead of using
the calls made by the operating system as it tracks the focus.
See also @racket[frame:lookup-focus-table], @racket[test:use-focus-table]
and @racket[test:get-active-top-level-window].
@defmethod[#:mode override (show [on? boolean?]) void?]{
When @racket[on?] is @racket[#t], adds this frame to the
front of the list of frames stored with the frame's eventspace. When
@racket[on?] is @racket[#f], this method removes this frame
from the list.
See also @racket[frame:lookup-focus-table], @racket[test:use-focus-table]
and @racket[test:get-active-top-level-window].
}
@defmethod[#:mode augment (on-close) void?]{
Removes this frame from the list of frames stored with the frame's eventspace.
See also @racket[frame:lookup-focus-table], @racket[test:use-focus-table]
and @racket[test:get-active-top-level-window].
}
}
@definterface[frame:size-pref<%> (frame:basic<%>)]{ @definterface[frame:size-pref<%> (frame:basic<%>)]{
} }
@ -264,7 +295,9 @@
} }
@defmixin[frame:status-line-mixin (frame:basic<%>) (frame:status-line<%>)]{ @defmixin[frame:status-line-mixin (frame:basic<%>) (frame:status-line<%>)]{
@defmethod*[#:mode override (((make-root-area-container (class (subclass?/c panel%)) (parent (is-a?/c panel%))) (is-a?/c panel%)))]{ @defmethod*[#:mode override (((make-root-area-container (class (subclass?/c panel%))
(parent (is-a?/c panel%)))
(is-a?/c panel%)))]{
Adds a panel at the bottom of the frame to hold the status Adds a panel at the bottom of the frame to hold the status
lines. lines.
@ -344,7 +377,9 @@
The result of this mixin uses the same initialization arguments as the The result of this mixin uses the same initialization arguments as the
mixin's argument. mixin's argument.
@defmethod*[#:mode override (((make-root-area-container (class (subclass?/c area-container<%>)) (parent (is-a?/c area-container<%>))) (is-a?/c area-container<%>)))]{ @defmethod*[#:mode override (((make-root-area-container (class (subclass?/c area-container<%>))
(parent (is-a?/c area-container<%>)))
(is-a?/c area-container<%>)))]{
Builds an extra panel for displaying various information. Builds an extra panel for displaying various information.
} }
@ -526,7 +561,16 @@
(height (or/c (integer-in 0 10000) false/c) #f) (height (or/c (integer-in 0 10000) false/c) #f)
(x (or/c (integer-in -10000 10000) false/c) #f) (x (or/c (integer-in -10000 10000) false/c) #f)
(y (or/c (integer-in -10000 10000) false/c) #f) (y (or/c (integer-in -10000 10000) false/c) #f)
(style (listof (or/c 'no-resize-border 'no-caption 'no-system-menu 'hide-menu-bar 'mdi-parent 'mdi-child 'toolbar-button 'float 'metal)) null) (style (listof (or/c 'no-resize-border
'no-caption
'no-system-menu
'hide-menu-bar
'mdi-parent
'mdi-child
'toolbar-button
'float
'metal))
null)
(enabled any/c #t) (enabled any/c #t)
(border (integer-in 0 1000) 0) (border (integer-in 0 1000) 0)
(spacing (integer-in 0 1000) 0) (spacing (integer-in 0 1000) 0)
@ -590,7 +634,9 @@
returns @racket[#t]. returns @racket[#t].
} }
@defmethod*[#:mode override (((file-menu:save-as-callback (item (is-a?/c menu-item%)) (evt (is-a?/c control-event%))) void?))]{ @defmethod*[#:mode override (((file-menu:save-as-callback (item (is-a?/c menu-item%))
(evt (is-a?/c control-event%)))
void?))]{
Prompts the user for a file name and uses that filename to save the buffer. Prompts the user for a file name and uses that filename to save the buffer.
Calls @method[frame:editor<%> save-as] with no arguments. Calls @method[frame:editor<%> save-as] with no arguments.
} }
@ -599,7 +645,9 @@
returns @racket[#t]. returns @racket[#t].
} }
@defmethod*[#:mode override (((file-menu:print-callback (item (is-a?/c menu-item%)) (evt (is-a?/c control-event%))) void?))]{ @defmethod*[#:mode override (((file-menu:print-callback (item (is-a?/c menu-item%))
(evt (is-a?/c control-event%)))
void?))]{
Calls the @method[editor<%> print] method of @racket[editor<%>] with the Calls the @method[editor<%> print] method of @racket[editor<%>] with the
default arguments, except that the @racket[output-mode] argument is the default arguments, except that the @racket[output-mode] argument is the
result of calling @racket[preferences:get] with result of calling @racket[preferences:get] with
@ -619,7 +667,9 @@
text. text.
} }
@defmethod*[#:mode override (((help-menu:about-callback (item (is-a?/c menu-item%)) (evt (is-a?/c control-event%))) void?))]{ @defmethod*[#:mode override (((help-menu:about-callback (item (is-a?/c menu-item%))
(evt (is-a?/c control-event%)))
void?))]{
Calls @racket[message-box] with a message welcoming the user to the Calls @racket[message-box] with a message welcoming the user to the
application named by @racket[application:current-app-name] application named by @racket[application:current-app-name]
} }
@ -663,7 +713,9 @@
@racket['framework:open-here?] is set. @racket['framework:open-here?] is set.
} }
@defmethod*[#:mode override (((file-menu:new-callback (item (is-a?/c menu-item%)) (evt (is-a?/c control-event%))) void?))]{ @defmethod*[#:mode override (((file-menu:new-callback (item (is-a?/c menu-item%))
(evt (is-a?/c control-event%)))
void?))]{
When the preference @racket['framework:open-here?] preference is set, this When the preference @racket['framework:open-here?] preference is set, this
method prompts the user, asking if they would like to create a new frame, method prompts the user, asking if they would like to create a new frame,
or just clear out this one. If they clear it out and the file hasn't been or just clear out this one. If they clear it out and the file hasn't been
@ -766,7 +818,9 @@
Adds support for a 20,000-feet view via @racket[text:delegate<%>] and Adds support for a 20,000-feet view via @racket[text:delegate<%>] and
@racket[text:delegate-mixin]. @racket[text:delegate-mixin].
@defmethod*[#:mode override (((make-root-area-container (class (subclass?/c panel%)) (parent (is-a?/c panel%))) (is-a?/c panel%)))]{ @defmethod*[#:mode override (((make-root-area-container (class (subclass?/c panel%))
(parent (is-a?/c panel%)))
(is-a?/c panel%)))]{
Adds a panel outside to hold the delegate @racket[editor-canvas%] and Adds a panel outside to hold the delegate @racket[editor-canvas%] and
@racket[text%]. @racket[text%].
} }
@ -867,7 +921,10 @@
returns @racket[#t]. returns @racket[#t].
} }
@defmethod*[#:mode override (((edit-menu:find-again-backwards-callback (item (is-a?/c menu-item%)) (evt (is-a?/c control-event%))) void?))]{ @defmethod*[#:mode override (((edit-menu:find-again-backwards-callback
(item (is-a?/c menu-item%))
(evt (is-a?/c control-event%)))
void?))]{
Calls @method[frame:searchable unhide-search] and then Calls @method[frame:searchable unhide-search] and then
@method[frame:searchable<%> search]. @method[frame:searchable<%> search].
} }

2
collects/scribblings/framework/main-extracts.rkt
View File

@ -1,4 +1,4 @@
#lang scheme/base #lang racket/base
(require scribble/extract) (require scribble/extract)
(provide-extracted (lib "framework/main.rkt")) (provide-extracted (lib "framework/main.rkt"))

71
collects/scribblings/gui/dialog-funcs.scrbl
View File

@ -14,8 +14,9 @@ These functions get input from the user and/or display
[directory (or/c path-string? #f) #f] [directory (or/c path-string? #f) #f]
[filename (or/c path-string? #f) #f] [filename (or/c path-string? #f) #f]
[extension (or/c string? #f) #f] [extension (or/c string? #f) #f]
[style (listof (or/c 'packages 'enter-packages)) null] [style (listof (or/c 'packages 'enter-packages 'common)) null]
[filters (listof (list/c string? string?)) '(("Any" "*.*"))]) [filters (listof (list/c string? string?)) '(("Any" "*.*"))]
[#:dialog-mixin dialog-mixin (make-mixin-contract path-dialog%) (λ (x) x)])
(or/c path? #f)]{ (or/c path? #f)]{
Obtains a file pathname from the user via the platform-specific Obtains a file pathname from the user via the platform-specific
@ -65,8 +66,10 @@ On Windows and Unix, @racket[filters] determines a set of filters from
that have any of these suffixes in any filter are selectable; a that have any of these suffixes in any filter are selectable; a
@racket["*.*"] glob makes all files available for selection. @racket["*.*"] glob makes all files available for selection.
See also @racket[path-dialog%]. The @racket[dialog-mixin] is applied to @racket[path-dialog%] before
creating an instance of the class for this dialog.
See also @racket[path-dialog%] for a richer interface.
} }
@ -75,8 +78,9 @@ See also @racket[path-dialog%].
[directory (or/c path-string? #f) #f] [directory (or/c path-string? #f) #f]
[filename (or/c path-string? #f) #f] [filename (or/c path-string? #f) #f]
[extension (or/c string? #f) #f] [extension (or/c string? #f) #f]
[style null? null] [style (listof (or/c 'packages 'enter-packages 'common)) null]
[filters (listof (list/c string? string?)) '(("Any" "*.*"))]) [filters (listof (list/c string? string?)) '(("Any" "*.*"))]
[#:dialog-mixin dialog-mixin (make-mixin-contract path-dialog%) (λ (x) x)])
(or/c (listof path?) #f)]{ (or/c (listof path?) #f)]{
Like Like
@racket[get-file], except that the user can select multiple files, and the @racket[get-file], except that the user can select multiple files, and the
@ -89,8 +93,9 @@ Like
[directory (or/c path-string? #f) #f] [directory (or/c path-string? #f) #f]
[filename (or/c path-string? #f) #f] [filename (or/c path-string? #f) #f]
[extension (or/c string? #f) #f] [extension (or/c string? #f) #f]
[style (listof (or/c 'packages 'enter-packages)) null] [style (listof (or/c 'packages 'enter-packages 'common)) null]
[filters (listof (list/c string? string?)) '(("Any" "*.*"))]) [filters (listof (list/c string? string?)) '(("Any" "*.*"))]
[#:dialog-mixin dialog-mixin (make-mixin-contract path-dialog%) (λ (x) x)])
(or/c path? #f)]{ (or/c path? #f)]{
Obtains a file pathname from the user via the platform-specific Obtains a file pathname from the user via the platform-specific
@ -149,14 +154,17 @@ On Unix, @racket[extension] is ignored, and @racket[filters] is used
The @racket[style] list is treated as for @racket[get-file]. The @racket[style] list is treated as for @racket[get-file].
See also @racket[path-dialog%]. The @racket[dialog-mixin] is applied to @racket[path-dialog%] before
creating an instance of the class for this dialog.
See also @racket[path-dialog%] for a richer interface.
} }
@defproc[(get-directory [message (or/c string? #f) #f] @defproc[(get-directory [message (or/c string? #f) #f]
[parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #f) #f] [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #f) #f]
[directory (or/c path? #f) #f] [directory (or/c path? #f) #f]
[style (listof (or/c 'enter-packages)) null]) [style (listof (or/c 'enter-packages 'common)) null]
[#:dialog-mixin dialog-mixin (make-mixin-contract path-dialog%) (λ (x) x)])
(or/c path #f)]{ (or/c path #f)]{
Obtains a directory pathname from the user via the platform-specific Obtains a directory pathname from the user via the platform-specific
@ -178,13 +186,18 @@ specified. The latter
package. A package is a directory with a special suffix (e.g., package. A package is a directory with a special suffix (e.g.,
``.app'') that the Finder normally displays like a file. ``.app'') that the Finder normally displays like a file.
See also @racket[path-dialog%]. The @racket[dialog-mixin] is applied to @racket[path-dialog%] before
creating an instance of the class for this dialog.
See also @racket[path-dialog%] for a richer interface.
} }
@defproc[(message-box [title label-string?] @defproc[(message-box [title label-string?]
[message string?] [message string?]
[parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #f) #f] [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #f) #f]
[style (listof (or/c 'ok 'ok-cancel 'yes-no 'caution 'stop)) '(ok)]) [style (listof (or/c 'ok 'ok-cancel 'yes-no 'caution 'stop)) '(ok)]
[#:dialog-mixin dialog-mixin (make-mixin-contract dialog%) values])
(or/c 'ok 'cancel 'yes 'no)]{ (or/c 'ok 'cancel 'yes 'no)]{
See also @racket[message-box/custom]. See also @racket[message-box/custom].
@ -227,10 +240,14 @@ The class that implements the dialog provides a @racket[get-message]
a string. (The dialog is accessible through the a string. (The dialog is accessible through the
@racket[get-top-level-windows] function.) @racket[get-top-level-windows] function.)
The @racket[message-box] function can be called int a thread other The @racket[message-box] function can be called in a thread other
than the handler thread of the relevant eventspace (i.e., the eventspace of than the handler thread of the relevant eventspace (i.e., the eventspace of
@racket[parent], or the current eventspace if @racket[parent] is @racket[#f]), in which case the @racket[parent], or the current eventspace if @racket[parent] is @racket[#f]), in which case the
current thread blocks while the dialog runs on the handler thread.} current thread blocks while the dialog runs on the handler thread.
The @racket[dialog-mixin] argument is applied to the class that implements the dialog
before the dialog is created.
}
@defproc[(message-box/custom [title label-string?] @defproc[(message-box/custom [title label-string?]
[message string] [message string]
@ -242,7 +259,8 @@ The @racket[message-box] function can be called int a thread other
'disallow-close 'no-default 'disallow-close 'no-default
'default=1 'default=2 'default=3)) 'default=1 'default=2 'default=3))
'(no-default)] '(no-default)]
[close-result any/c #f]) [close-result any/c #f]
[#:dialog-mixin dialog-mixin (make-mixin-contract dialog%) values])
(or/c 1 2 3 close-result)]{ (or/c 1 2 3 close-result)]{
Displays a message to the user in a (modal) dialog, using Displays a message to the user in a (modal) dialog, using
@ -312,10 +330,14 @@ The class that implements the dialog provides a @racket[get-message]
a string. (The dialog is accessible through the a string. (The dialog is accessible through the
@racket[get-top-level-windows] function.) @racket[get-top-level-windows] function.)
The @racket[message-box/custom] function can be called int a thread The @racket[message-box/custom] function can be called in a thread
other than the handler thread of the relevant eventspace (i.e., the eventspace of other than the handler thread of the relevant eventspace (i.e., the eventspace of
@racket[parent], or the current eventspace if @racket[parent] is @racket[#f]), in which case the @racket[parent], or the current eventspace if @racket[parent] is @racket[#f]), in which case the
current thread blocks while the dialog runs on the handler thread.} current thread blocks while the dialog runs on the handler thread.
The @racket[dialog-mixin] argument is applied to the class that implements the dialog
before the dialog is created.
}
@defproc[(message+check-box [title label-string?] @defproc[(message+check-box [title label-string?]
[message string?] [message string?]
@ -323,7 +345,8 @@ The @racket[message-box/custom] function can be called int a thread
[parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #f) #f] [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #f) #f]
[style (listof (or/c 'ok 'ok-cancel 'yes-no [style (listof (or/c 'ok 'ok-cancel 'yes-no
'caution 'stop 'checked)) 'caution 'stop 'checked))
'(ok)]) '(ok)]
[#:dialog-mixin dialog-mixin (make-mixin-contract dialog%) values])
(values (or/c 'ok 'cancel 'yes 'no) boolean?)]{ (values (or/c 'ok 'cancel 'yes 'no) boolean?)]{
See also @racket[message+check-box/custom]. See also @racket[message+check-box/custom].
@ -349,7 +372,8 @@ Like @racket[message-box], except that
'disallow-close 'no-default 'disallow-close 'no-default
'default=1 'default=2 'default=3)) 'default=1 'default=2 'default=3))
'(no-default)] '(no-default)]
[close-result any/c #f]) [close-result any/c #f]
[#:dialog-mixin dialog-mixin (make-mixin-contract dialog%) values])
(or/c 1 2 3 (λ (x) (eq? x close-result)))]{ (or/c 1 2 3 (λ (x) (eq? x close-result)))]{
Like @racket[message-box/custom], except that Like @racket[message-box/custom], except that
@ -360,17 +384,14 @@ Like @racket[message-box/custom], except that
@item{@racket[style] can contain @racket['checked] to indicate that the check box @item{@racket[style] can contain @racket['checked] to indicate that the check box
should be initially checked.} should be initially checked.}
] ]
} }
@defproc[(get-text-from-user [title string?] @defproc[(get-text-from-user [title string?]
[message (or/c string? #f)] [message (or/c string? #f)]
[parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #f) #f] [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #f) #f]
[init-val string? ""] [init-val string? ""]
[style (listof 'password) null]) [style (listof 'password) null]
[#:dialog-mixin dialog-mixin (make-mixin-contract dialog%) values])
(or/c string? #f)]{ (or/c string? #f)]{
Gets a text string from the user via a modal dialog, using Gets a text string from the user via a modal dialog, using
@ -386,8 +407,8 @@ If @racket[style] includes @racket['password], the dialog's text field
draws each character of its content using a generic symbol, instead draws each character of its content using a generic symbol, instead
of the actual character. of the actual character.
The @racket[dialog-mixin] argument is applied to the class that implements the dialog
before the dialog is created.
} }
@defproc[(get-choices-from-user [title string?] @defproc[(get-choices-from-user [title string?]

16
collects/scribblings/gui/global-draw-funcs.scrbl
View File

@ -29,7 +29,8 @@ Returns the depth of the main display (a value of 1 denotes a monochrome display
@defproc[(get-display-left-top-inset [avoid-bars? any/c #f] @defproc[(get-display-left-top-inset [avoid-bars? any/c #f]
[#:monitor monitor exact-nonnegative-integer? 0]) [#:monitor monitor exact-nonnegative-integer? 0])
(values exact-nonnegative-integer? exact-nonnegative-integer?)]{ (values (or/c exact-nonnegative-integer? #f)
(or/c exact-nonnegative-integer? #f))]{
When the optional argument is @racket[#f] (the default), this function When the optional argument is @racket[#f] (the default), this function
returns the offset of @racket[monitor]'s origin from the returns the offset of @racket[monitor]'s origin from the
@ -46,13 +47,15 @@ When the optional @racket[avoid-bars?] argument is true, for @racket[monitor]
monitor @racket[0], the result is always @racket[0] and @racket[0]. monitor @racket[0], the result is always @racket[0] and @racket[0].
For monitors other than @racket[0], @racket[avoid-bars?] has no effect. For monitors other than @racket[0], @racket[avoid-bars?] has no effect.
If @racket[monitor] is not less than the current number of available monitors, the If @racket[monitor] is not less than the current number of available
@racket[exn:fail] exception is raised.} monitors (which can change at any time), the results are @racket[#f]
and @racket[#f].}
@defproc[(get-display-size [full-screen? any/c #f] @defproc[(get-display-size [full-screen? any/c #f]
[#:monitor monitor exact-nonnegative-integer? 0]) [#:monitor monitor exact-nonnegative-integer? 0])
(values exact-nonnegative-integer? exact-nonnegative-integer?)]{ (values (or/c exact-nonnegative-integer? #f)
(or/c exact-nonnegative-integer? #f))]{
@index["screen resolution"]{Gets} the physical size of the specified @racket[monitor] in @index["screen resolution"]{Gets} the physical size of the specified @racket[monitor] in
pixels. On Windows, this size does not include the task bar by pixels. On Windows, this size does not include the task bar by
@ -62,8 +65,9 @@ If @racket[monitor] is not less than the current number of available monitors, t
On Windows and Mac OS X, if the optional argument is true and @racket[monitor] is @racket[0], then On Windows and Mac OS X, if the optional argument is true and @racket[monitor] is @racket[0], then
the task bar, menu bar, and dock area are included in the result. the task bar, menu bar, and dock area are included in the result.
If @racket[monitor] is not less than the current number of available monitors, the If @racket[monitor] is not less than the current number of available
@racket[exn:fail] exception is raised.} monitors (which can change at any time), the results are @racket[#f]
and @racket[#f].}
@defproc[(is-color-display?) @defproc[(is-color-display?)