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/private/sig
(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
framework/test
@ -709,7 +714,24 @@
@racket[bitmap% get-loaded-mask]) and @racket['large].}]
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
group:get-the-frame-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%)
color
(if color mismatch-color (get-match-color)))
(= caret-pos (+ start-pos start)))])
(= caret-pos (+ start-pos start))
'low)])
(set! clear-old-locations
(let ([old clear-old-locations])
(λ ()

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

@ -1,14 +1,15 @@
#lang scheme/unit
(require string-constants
(prefix-in r: racket/gui/base)
"sig.rkt"
"../preferences.rkt"
mred/mred-sig
scheme/path)
(import mred^
[prefix keymap: framework:keymap^])
[prefix keymap: framework:keymap^]
[prefix frame: framework:frame^])
(export (rename framework:finder^
[-put-file put-file]
@ -44,7 +45,8 @@
[name (or (and (string? name) (file-name-from-path name))
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))
(let* ([f (normal-case-path (simple-form-path f))]
[dir (path-only f)]
@ -60,6 +62,7 @@
#f]
[else f]))))))
(define op (current-output-port))
(define (*get-file style)
(lambda ([directory #f]
[prompt (string-constant select-file)]
@ -67,7 +70,8 @@
[filter-msg (string-constant file-wrong-form)]
[parent-win (dialog-parent-parameter)])
(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))
(cond [(directory-exists? f)
(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"
"../gui-utils.rkt"
"bday.rkt"
framework/private/focus-table
mrlib/close-icon
mred/mred-sig
scheme/path)
@ -131,6 +132,26 @@
editing-this-file?
get-filename
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
(mixin ((class->interface frame%)) (basic<%>)
@ -190,12 +211,11 @@
(λ (% parent)
(make-object % parent)))
(inherit can-close? on-close)
(define/public close
(λ ()
(when (can-close?)
(on-close)
(show #f))))
(inherit on-close can-close?)
(define/public (close)
(when (can-close?)
(on-close)
(show #f)))
(inherit accept-drop-files)
@ -2710,7 +2730,7 @@
(min-width (+ (inexact->exact (ceiling indicator-width)) 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 info% (info-mixin basic%))
(define text-info% (text-info-mixin info%))

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

@ -120,25 +120,29 @@
;; add-to-recent : path -> void
(define (add-to-recent filename)
(let* ([old-list (preferences:get 'framework:recently-opened-files/pos)]
[old-ents (filter (λ (x) (string=? (path->string (car x))
(path->string filename)))
old-list)]
[old-ent (if (null? old-ents)
#f
(car old-ents))]
[new-ent (list filename
(if old-ent (cadr old-ent) 0)
(if old-ent (caddr old-ent) 0))]
[added-in (cons new-ent
(remove new-ent old-list compare-recent-list-items))]
[new-recent (size-down added-in
(preferences:get 'framework:recent-max-count))])
(preferences:set 'framework:recently-opened-files/pos new-recent)))
(define old-list (preferences:get 'framework:recently-opened-files/pos))
(define old-ents (filter (λ (x) (recently-opened-files-same-enough-path? (car x) filename))
old-list))
(define new-ent (if (null? old-ents)
(list filename 0 0)
(cons filename (cdr (car old-ents)))))
(define added-in (cons new-ent
(remove* (list new-ent)
old-list
(λ (l1 l2)
(recently-opened-files-same-enough-path? (car l1) (car l2))))))
(define new-recent (size-down added-in
(preferences:get 'framework:recent-max-count)))
(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]
;; takes a list of stuff and returns the
@ -167,8 +171,8 @@
(preferences:get 'framework:recently-opened-files/pos)]
[new-recent-items
(map (λ (x)
(if (string=? (path->string (car x))
(path->string filename))
(if (recently-opened-files-same-enough-path? (path->string (car x))
(path->string filename))
(list* (car x) start end (cdddr x))
x))
(preferences:get 'framework:recently-opened-files/pos))])
@ -198,9 +202,8 @@
(define (recent-list-item->menu-label recent-list-item)
(let ([filename (car recent-list-item)])
(gui-utils:trim-string
(regexp-replace* #rx"&" (path->string filename) "\\&\\&")
200)))
(gui-utils:quote-literal-label
(path->string filename))))
;; 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
@ -232,8 +235,12 @@
(send ed set-position start end)))))]
[else
(preferences:set 'framework:recently-opened-files/pos
(remove recent-list-item
(preferences:get 'framework:recently-opened-files/pos)))
(remove* (list recent-list-item)
(preferences:get 'framework:recently-opened-files/pos)
(λ (l1 l2)
(recently-opened-files-same-enough-path?
(car l1)
(car l2)))))
(message-box (string-constant error)
(format (string-constant cannot-open-because-dne)
filename))])))

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

@ -256,6 +256,7 @@
(define-signature frame-class^
(basic<%>
focus-table<%>
size-pref<%>
register-group<%>
status-line<%>
@ -285,6 +286,7 @@
delegate%
pasteboard%
focus-table-mixin
basic-mixin
size-pref-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)
#\w
'(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
#t)
(make-between 'file-menu 'close 'quit 'nothing)
@ -387,8 +389,8 @@
(make-an-item 'edit-menu 'replace
'(string-constant replace-info)
'(λ (item control) (void))
#\r
'(get-default-shortcut-prefix)
#\f
'(cons 'shift (get-default-shortcut-prefix))
'(string-constant replace-menu-item)
on-demand-do-nothing
#f)

98
collects/framework/test.rkt
View File

@ -1,10 +1,12 @@
#lang at-exp scheme/gui
(require scribble/srcdoc)
(require/doc scheme/base scribble/manual)
(require scribble/srcdoc
(prefix-in :: framework/private/focus-table))
(require/doc scheme/base scribble/manual
(for-label framework))
(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
(let loop ([tlw tlw])
(or (pred tlw)
@ -165,16 +167,30 @@
(define current-get-eventspaces
(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)
(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))))
(define (get-focused-window)
(let ([f (get-active-frame)])
(let ([f (test:get-active-top-level-window)])
(and f
(send f get-focus-window))))
(send f get-edit-target-window))))
(define time-stamp current-milliseconds)
@ -200,14 +216,13 @@
;; get-parent returns () for no parent.
;;
(define in-active-frame?
(λ (window)
(let ([frame (get-active-frame)])
(let loop ([window window])
(cond [(not window) #f]
[(null? window) #f] ;; is this test needed?
[(eq? window frame) #t]
[else (loop (send window get-parent))])))))
(define (in-active-frame? window)
(let ([frame (test:get-active-top-level-window)])
(let loop ([window window])
(cond [(not window) #f]
[(null? window) #f] ;; is this test needed?
[(eq? window frame) #t]
[else (loop (send window get-parent))]))))
;;
;; Verify modifier list.
@ -239,7 +254,7 @@
(cond
[(or (string? b-desc)
(procedure? b-desc))
(let* ([active-frame (get-active-frame)]
(let* ([active-frame (test:get-active-top-level-window)]
[_ (unless active-frame
(error object-tag
"could not find object: ~a, no active frame"
@ -516,7 +531,7 @@
[else
(error
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]
[else (loop (cdr l))])))
@ -573,21 +588,20 @@
(define menu-tag 'test:menu-select)
(define menu-select
(λ (menu-name . item-names)
(cond
[(not (string? menu-name))
(error menu-tag "expects string, given: ~e" menu-name)]
[(not (andmap string? item-names))
(error menu-tag "expects strings, given: ~e" item-names)]
[else
(run-one
(λ ()
(let* ([frame (get-active-frame)]
[item (get-menu-item frame (cons menu-name item-names))]
[evt (make-object control-event% 'menu)])
(send evt set-time-stamp (current-milliseconds))
(send item command evt))))])))
(define (menu-select menu-name . item-names)
(cond
[(not (string? menu-name))
(error menu-tag "expects string, given: ~e" menu-name)]
[(not (andmap string? item-names))
(error menu-tag "expects strings, given: ~e" item-names)]
[else
(run-one
(λ ()
(let* ([frame (test:get-active-top-level-window)]
[item (get-menu-item frame (cons menu-name item-names))]
[evt (make-object control-event% 'menu)])
(send evt set-time-stamp (current-milliseconds))
(send item command evt))))]))
(define get-menu-item
(λ (frame item-names)
@ -1021,7 +1035,7 @@
test:top-level-focus-window-has?
(-> (-> (is-a?/c area<%>) boolean?) boolean?)
(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
returns @racket[#f]. If there
is no top-level-focus-window, returns @racket[#f].})
@ -1041,4 +1055,20 @@
test:run-one
(-> (-> void?) void?)
(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
(require mzlib/class
mzlib/etc
mzlib/list
(prefix wx: "kernel.rkt")
(prefix wx: racket/snip)
(rename "wxme/cycle.rkt" wx:set-editor-get-file! set-editor-get-file!)
(rename "wxme/cycle.rkt" wx:set-editor-put-file! set-editor-put-file!)
"lock.rkt"
"wx.rkt"
"cycle.rkt"
"check.rkt"
"mrtop.rkt"
"path-dialog.rkt")
#lang racket/base
(require racket/class
(prefix-in wx: "kernel.rkt")
(rename-in "wxme/cycle.rkt"
[set-editor-get-file! wx:set-editor-get-file!]
[set-editor-put-file! wx:set-editor-put-file!])
"lock.rkt"
"wx.rkt"
"cycle.rkt"
"check.rkt"
"mrtop.rkt"
"path-dialog.rkt")
(provide get-file
get-file-list
put-file
get-directory)
(provide get-file
get-file-list
put-file
get-directory)
(define (mk-file-selector who put? multi? dir?)
(lambda (message parent directory filename extension style filters)
;; Calls from C++ have wrong kind of window:
(when (is-a? parent wx:window%)
(set! parent (as-entry (lambda () (wx->mred parent)))))
(define ((mk-file-selector who put? multi? dir?)
message parent directory filename extension style filters dialog-mixin)
;; Calls from C++ have wrong kind of window:
(when (is-a? parent wx:window%)
(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)
(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" "*.*")))
(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
;; `put-file' so that they have the right arities and names
(define-syntax define-file-selector
(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
(syntax-rules ()
[(_ name put? multi?)
(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-file-selector get-file-list #f #t)
(define-file-selector put-file #t #f)
(define-file-selector get-file #f #f)
(define-file-selector get-file-list #f #t)
(define-file-selector put-file #t #f)
(define (get-directory [message #f] [parent #f] [directory #f] [style null] #:dialog-mixin [dialog-mixin values])
((mk-file-selector 'get-directory #f #f #t)
message parent directory #f #f style null dialog-mixin))
(define get-directory
(opt-lambda ([message #f] [parent #f] [directory #f] [style null])
((mk-file-selector 'get-directory #f #f #t)
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))
(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
mzlib/class100
mzlib/etc
mzlib/string
(prefix wx: "kernel.rkt")
(prefix-in wx: "kernel.rkt")
"const.rkt"
"check.rkt"
"helper.rkt"
@ -24,7 +23,8 @@
(lambda (who title message
button1 button2 button3
parent style close-result
check? two-results? check-message)
check? two-results? check-message
dialog-mixin)
(check-label-string who title)
(check-string/false who message)
(when check?
@ -46,7 +46,8 @@
who title message
button1 button2 button3
parent style close-result
check? two-results? check-message))]
check? two-results? check-message
dialog-mixin))]
[es (if parent
(send parent get-eventspace)
(wx:current-eventspace))])
@ -65,51 +66,53 @@
(lambda (who title message
button1 button2 button3
parent style close-result
check? two-results? check-message)
check? two-results? check-message
dialog-mixin)
(let* ([strings (regexp-split #rx"\n" message)]
[single? (and (< (length strings) 10)
(andmap (lambda (s) (< (string-length s) 60)) strings))]
[f (make-object (class100 dialog% ()
(public
[get-message
(lambda () message)])
(augment
[can-close? (lambda ()
(if (memq 'disallow-close style)
(begin
(wx:bell)
#f)
#t))])
(override
[on-subwindow-event
(lambda (w e)
(if (send e button-down?)
(if (is-a? w button%)
#f
(if (or (is-a? w message%)
(and
(is-a? w editor-canvas%)
(let-values ([(w h) (send w get-client-size)])
(< (send e get-x) w))))
(begin
(send w popup-menu
(let ([m (make-object popup-menu%)])
(make-object menu-item%
"Copy Message"
m
(lambda (i e)
(send (wx:get-the-clipboard)
set-clipboard-string
message
(send e get-time-stamp))))
m)
(send e get-x)
(send e get-y))
#t)
#f))
#f))])
(sequence
(super-init title parent box-width))))]
[f (make-object (dialog-mixin
(class100 dialog% ()
(public
[get-message
(lambda () message)])
(augment
[can-close? (lambda ()
(if (memq 'disallow-close style)
(begin
(wx:bell)
#f)
#t))])
(override
[on-subwindow-event
(lambda (w e)
(if (send e button-down?)
(if (is-a? w button%)
#f
(if (or (is-a? w message%)
(and
(is-a? w editor-canvas%)
(let-values ([(w h) (send w get-client-size)])
(< (send e get-x) w))))
(begin
(send w popup-menu
(let ([m (make-object popup-menu%)])
(make-object menu-item%
"Copy Message"
m
(lambda (i e)
(send (wx:get-the-clipboard)
set-clipboard-string
message
(send e get-time-stamp))))
m)
(send e get-x)
(send e get-y))
#t)
#f))
#f))])
(sequence
(super-init title parent box-width)))))]
[result close-result]
[icon-id (cond
[(memq 'stop style) 'stop]
@ -224,20 +227,21 @@
result))))))
(define message-box/custom
(opt-lambda (title message
button1
button2
button3
[parent #f]
[style '(no-default)]
[close-result #f])
(lambda (title message
button1
button2
button3
[parent #f]
[style '(no-default)]
[close-result #f]
#:dialog-mixin [dialog-mixin values])
(do-message-box/custom 'message-box/custom
title message button1 button2 button3
parent style close-result
#f #f #f)))
#f #f #f dialog-mixin)))
(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-string/false who message)
(when check?
@ -276,7 +280,8 @@
(list default)
(list default 'disallow-close)))
close-val
check? #t check-message)])
check? #t check-message
dialog-mixin)])
(let ([result (case result
[(1) one-v]
[(2) two-v])])
@ -285,23 +290,25 @@
result))))))
(define message-box
(opt-lambda (title message [parent #f] [style '(ok)])
(do-message-box 'message-box title message parent style #f #f)))
(lambda (title message [parent #f] [style '(ok)] #:dialog-mixin [dialog-mixin values])
(do-message-box 'message-box title message parent style #f #f dialog-mixin)))
(define message+check-box/custom
(opt-lambda (title message
(lambda (title message
checkbox-message
button1
button2
button3
[parent #f]
[style '(no-default)]
[close-result #f])
[close-result #f]
#:dialog-mixin [dialog-mixin values])
(do-message-box/custom 'message+check-box/custom
title message button1 button2 button3
parent style close-result
#t #t checkbox-message)))
parent style close-result
#t #t checkbox-message
dialog-mixin)))
(define message+check-box
(opt-lambda (title message check-message [parent #f] [style '(ok)])
(do-message-box 'message-box title message parent style #t check-message))))
(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 dialog-mixin)))

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

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

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

@ -86,6 +86,19 @@
(when wxb
(let ([wx (->wx wxb)])
(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)
(send wx install-wait-cursor)
(send wx install-mb)
@ -344,7 +357,8 @@
(define/public (force-window-focus)
(let ([next (get-app-front-window)])
(cond
[next (tellv next makeKeyWindow)]
[next
(tellv next makeKeyWindow)]
[root-fake-frame
;; Make key focus shift to root frame:
(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))
(tellv apple addItem: item)
(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)
(tellv apple addItem: (tell NSMenuItem separatorItem))
(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 (display-origin xb yb all? num)
(define (display-origin xb yb all? num fail)
(if (or all? (positive? num))
(unless (atomically
(with-autorelease
@ -108,13 +108,13 @@
(NSSize-height (NSRect-size f0)))))))
#t)
#f))))
(error 'get-display-left-top-inset "no such monitor: ~v" num))
(fail))
(set-box! xb 0))
(when (zero? num)
(set-box! yb 0))
(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
(with-autorelease
(let ([screens (tell NSScreen screens)])
@ -134,7 +134,7 @@
(get-menu-bar-height)]))))
#t)
#f))))
(error 'get-display-size "no such monitor: ~v" num)))
(fail)))
(define (display-count)

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

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

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

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

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

@ -54,6 +54,7 @@
queue-quit-event
queue-prefs-event
queue-about-event
queue-file-event
begin-busy-cursor
@ -571,6 +572,10 @@
;; called in event-pump thread
(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)
;; called in event-pump thread
(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)
(gtk_fixed_set_has_window client-gtk #t)) ; imposes clipping
(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 v client-gtk #t #t 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)
(set-box! sx-box (send p get-x))
(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)]
[sh (unbox sh-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_n_monitors (_fun _GdkScreen -> _int))
(define (monitor-rect who num)
(define (monitor-rect num fail)
(let ([s (gdk_screen_get_default)]
[r (make-GdkRectangle 0 0 0 0)])
(unless (num . < . (gdk_screen_get_n_monitors s))
(error who "no such monitor: ~v" num))
(fail))
(gdk_screen_get_monitor_geometry s num r)
r))
(define (display-origin x y all? num)
(let ([r (monitor-rect 'get-display-left-top-inset num)])
(define (display-origin x y all? num fail)
(let ([r (monitor-rect num fail)])
(set-box! x (- (GdkRectangle-x r)))
(set-box! y (- (GdkRectangle-y r)))))
(define (display-size w h all? num)
(let ([r (monitor-rect 'get-display-size num)])
(define (display-size w h all? num fail)
(let ([r (monitor-rect num fail)])
(set-box! w (GdkRectangle-width r))
(set-box! h (GdkRectangle-height r))))

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

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

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

@ -181,25 +181,27 @@
(unless (unbox cnb)
(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]+)$"
title)])
(when m
(let ([mask (+ (if (list-ref m 1) GDK_CONTROL_MASK 0)
(if (list-ref m 2) GDK_SHIFT_MASK 0)
(if (list-ref m 3) GDK_MOD1_MASK 0)
(if (list-ref m 4) GDK_META_MASK 0))]
[code (let ([s (list-ref m 5)])
(if (= 1 (string-length s))
(gdk_unicode_to_keyval
(char->integer (string-ref s 0)))
(string->number s)))])
(unless (zero? code)
(let ([accel-path (format "<GRacket>/Hardwired/~a" title)])
(gtk_accel_map_add_entry accel-path
code
mask)
(gtk_menu_item_set_accel_path item-gtk accel-path)))))))
(if m
(let ([mask (+ (if (list-ref m 1) GDK_CONTROL_MASK 0)
(if (list-ref m 2) GDK_SHIFT_MASK 0)
(if (list-ref m 3) GDK_MOD1_MASK 0)
(if (list-ref m 4) GDK_META_MASK 0))]
[code (let ([s (list-ref m 5)])
(if (= 1 (string-length s))
(gdk_unicode_to_keyval
(char->integer (string-ref s 0)))
(string->number s)))])
(unless (zero? code)
(let ([accel-path (format "<GRacket>/Hardwired/~a" title)])
(gtk_accel_map_add_entry accel-path
code
mask)
(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])
(define (append-item i label help-str-or-submenu chckable?)
@ -226,7 +228,7 @@
[menu-item i]
[parent this])])
(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_widget_show item-gtk))))
@ -258,7 +260,8 @@
(let ([gtk (find-gtk item)])
(when 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?)
(let ([gtk (find-gtk item)])

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

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

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

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

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

@ -242,7 +242,7 @@
(define/override (on-resized)
(reset-dc))
(define/private (reset-dc)
(define/private (reset-dc [refresh? #t])
(send dc reset-backing-retained)
(send dc set-auto-scroll
(if (get-virtual-width)
@ -250,16 +250,8 @@
0)
(if (get-virtual-height)
(get-virtual-v-pos)
0)))
(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))))))
0))
(when refresh? (refresh-one)))
(define/override (show-children)
(when (dc . is-a? . dc<%>)

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

@ -78,12 +78,12 @@
#f)
(reverse rects)))
(define (display-size xb yb all? num)
(define (display-size xb yb all? num fail)
(cond
[(positive? num)
(let ([rs (get-all-screen-rects)])
(unless (num . < . (length rs))
(error 'get-display-size "no such monitor: ~v" num))
(fail))
(let ([r (list-ref rs num)])
(set-box! xb (- (caddr r) (car r)))
(set-box! yb (- (cadddr r) (cadr r)))))]
@ -99,12 +99,12 @@
(set-box! xb (- (RECT-right r) (RECT-left 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
[(positive? num)
(let ([rs (get-all-screen-rects)])
(unless (num . < . (length rs))
(error 'get-display-left-top-inset "no such monitor: ~v" num))
(fail))
(let ([r (list-ref rs num)])
(set-box! xb (- (car r)))
(set-box! yb (- (cadr r)))))]
@ -435,7 +435,7 @@
[wh (box 0)]
[wx (box 0)]
[wy (box 0)])
(display-size sw sh #f 0)
(display-size sw sh #f 0 void)
(if wrt
(begin
(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])
(unless (exact-nonnegative-integer? monitor)
(raise-type-error 'get-display-size "exact non-negative integer" monitor))
(let ([xb (box 0)]
[yb (box 0)])
(wx:display-size xb yb full-screen? monitor)
(values (unbox xb) (unbox yb)))))
(let/ec esc
(let ([xb (box 0)]
[yb (box 0)])
(wx:display-size xb yb full-screen? monitor
(lambda () (esc #f #f)))
(values (unbox xb) (unbox yb))))))
(define get-display-left-top-inset
(lambda ([advisory? #f] #:monitor [monitor 0])
(unless (exact-nonnegative-integer? monitor)
(raise-type-error 'get-display-left-top-inset "exact non-negative integer" monitor))
(let ([xb (box 0)]
[yb (box 0)])
(wx:display-origin xb yb advisory? monitor)
(values (unbox xb) (unbox yb)))))
(let/ec esc
(let ([xb (box 0)]
[yb (box 0)])
(wx:display-origin xb yb advisory? monitor (lambda () (esc #f #f)))
(values (unbox xb) (unbox yb))))))
(define get-display-count
(lambda ()

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

@ -28,7 +28,9 @@
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
the clients of this frame and the frame itself. For example, to insert
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).
}
}
@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<%>)]{
}
@ -264,7 +295,9 @@
}
@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
lines.
@ -344,7 +377,9 @@
The result of this mixin uses the same initialization arguments as the
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.
}
@ -526,7 +561,16 @@
(height (or/c (integer-in 0 10000) false/c) #f)
(x (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)
(border (integer-in 0 1000) 0)
(spacing (integer-in 0 1000) 0)
@ -590,7 +634,9 @@
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.
Calls @method[frame:editor<%> save-as] with no arguments.
}
@ -599,7 +645,9 @@
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
default arguments, except that the @racket[output-mode] argument is the
result of calling @racket[preferences:get] with
@ -619,7 +667,9 @@
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
application named by @racket[application:current-app-name]
}
@ -663,7 +713,9 @@
@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
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
@ -766,7 +818,9 @@
Adds support for a 20,000-feet view via @racket[text:delegate<%>] and
@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
@racket[text%].
}
@ -867,7 +921,10 @@
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
@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)
(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]
[filename (or/c path-string? #f) #f]
[extension (or/c string? #f) #f]
[style (listof (or/c 'packages 'enter-packages)) null]
[filters (listof (list/c string? string?)) '(("Any" "*.*"))])
[style (listof (or/c 'packages 'enter-packages 'common)) null]
[filters (listof (list/c string? string?)) '(("Any" "*.*"))]
[#:dialog-mixin dialog-mixin (make-mixin-contract path-dialog%) (λ (x) x)])
(or/c path? #f)]{
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
@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]
[filename (or/c path-string? #f) #f]
[extension (or/c string? #f) #f]
[style null? null]
[filters (listof (list/c string? string?)) '(("Any" "*.*"))])
[style (listof (or/c 'packages 'enter-packages 'common)) null]
[filters (listof (list/c string? string?)) '(("Any" "*.*"))]
[#:dialog-mixin dialog-mixin (make-mixin-contract path-dialog%) (λ (x) x)])
(or/c (listof path?) #f)]{
Like
@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]
[filename (or/c path-string? #f) #f]
[extension (or/c string? #f) #f]
[style (listof (or/c 'packages 'enter-packages)) null]
[filters (listof (list/c string? string?)) '(("Any" "*.*"))])
[style (listof (or/c 'packages 'enter-packages 'common)) null]
[filters (listof (list/c string? string?)) '(("Any" "*.*"))]
[#:dialog-mixin dialog-mixin (make-mixin-contract path-dialog%) (λ (x) x)])
(or/c path? #f)]{
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].
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]
[parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #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)]{
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.,
``.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?]
[message string?]
[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)]{
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
@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
@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?]
[message string]
@ -242,7 +259,8 @@ The @racket[message-box] function can be called int a thread other
'disallow-close 'no-default
'default=1 'default=2 'default=3))
'(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)]{
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
@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
@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?]
[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]
[style (listof (or/c 'ok 'ok-cancel 'yes-no
'caution 'stop 'checked))
'(ok)])
'(ok)]
[#:dialog-mixin dialog-mixin (make-mixin-contract dialog%) values])
(values (or/c 'ok 'cancel 'yes 'no) boolean?)]{
See also @racket[message+check-box/custom].
@ -349,7 +372,8 @@ Like @racket[message-box], except that
'disallow-close 'no-default
'default=1 'default=2 'default=3))
'(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)))]{
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
should be initially checked.}
]
}
@defproc[(get-text-from-user [title string?]
[message (or/c string? #f)]
[parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #f) #f]
[init-val string? ""]
[style (listof 'password) null])
[style (listof 'password) null]
[#:dialog-mixin dialog-mixin (make-mixin-contract dialog%) values])
(or/c string? #f)]{
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
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?]

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]
[#: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
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].
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
@racket[exn:fail] exception is raised.}
If @racket[monitor] is not less than the current number of available
monitors (which can change at any time), the results are @racket[#f]
and @racket[#f].}
@defproc[(get-display-size [full-screen? any/c #f]
[#: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
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
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
@racket[exn:fail] exception is raised.}
If @racket[monitor] is not less than the current number of available
monitors (which can change at any time), the results are @racket[#f]
and @racket[#f].}
@defproc[(is-color-display?)