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

add frame:focus-table-mixin & related things to be able to make drracket

Browse Source 
test suites that don't depend on the OS giving any focus messages
This commit is contained in:
Robby Findler 2011-09-04 23:59:42 -05:00
parent bb71539233
commit a67f509f90
20 changed files with 243 additions and 110 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/drracket/private/debug.rkt
View File

@ -900,7 +900,8 @@ profile todo:
(message-box (string-constant drscheme) (message-box (string-constant drscheme)
(string-constant editor-changed-since-srcloc-recorded) (string-constant editor-changed-since-srcloc-recorded)
frame frame
'(ok caution)))) '(ok caution)
#:dialog-mixin frame:focus-table-mixin)))
(when (and rep editor) (when (and rep editor)
(when (is-a? editor text:basic<%>) (when (is-a? editor text:basic<%>)
(send rep highlight-errors same-src-srclocs '()) (send rep highlight-errors same-src-srclocs '())
@ -1007,7 +1008,8 @@ profile todo:
(string-constant test-coverage-clear-and-do-not-ask-again) (string-constant test-coverage-clear-and-do-not-ask-again)
(send (get-canvas) get-top-level-window) (send (get-canvas) get-top-level-window)
'(default=1) '(default=1)
2)]) 2
#:dialog-mixin frame:focus-table-mixin)])
(case msg-box-result (case msg-box-result
[(1) #t] [(1) #t]
[(2) #f] [(2) #f]
@ -1419,7 +1421,8 @@ profile todo:
(eq? (message-box (string-constant drscheme) (eq? (message-box (string-constant drscheme)
(string-constant profiling-clear?) (string-constant profiling-clear?)
frame frame
'(yes-no)) '(yes-no)
#:dialog-mixin frame:focus-table-mixin)
'yes)))))) 'yes))))))
(define/private (do-reset-profile) (define/private (do-reset-profile)
@ -1561,7 +1564,8 @@ profile todo:
(send (get-current-tab) refresh-profile)] (send (get-current-tab) refresh-profile)]
[else [else
(message-box (string-constant drscheme) (message-box (string-constant drscheme)
(string-constant profiling-no-information-available))])) (string-constant profiling-no-information-available)
#:dialog-mixin frame:focus-table-mixin)]))
(define/public (hide-profile-gui) (define/public (hide-profile-gui)
(when profile-gui-constructed? (when profile-gui-constructed?

9
collects/drracket/private/frame.rkt
View File

@ -295,7 +295,8 @@
[else [else
(message-box (string-constant drscheme) (message-box (string-constant drscheme)
(format (string-constant keybindings-planet-malformed-spec) (format (string-constant keybindings-planet-malformed-spec)
planet-spec))])))))) planet-spec)
#:dialog-mixin frame:focus-table-mixin)]))))))
(let ([ud (preferences:get 'drracket:user-defined-keybindings)]) (let ([ud (preferences:get 'drracket:user-defined-keybindings)])
(unless (null? ud) (unless (null? ud)
(new separator-menu-item% (parent keybindings-menu)) (new separator-menu-item% (parent keybindings-menu))
@ -343,7 +344,8 @@
(if (path? item) (if (path? item)
(path->string item) (path->string item)
(format "~s" item)) (format "~s" item))
(exn-message x))) (exn-message x))
#:dialog-mixin frame:focus-table-mixin)
#f)]) #f)])
(keymap:add-user-keybindings-file item) (keymap:add-user-keybindings-file item)
#t)) #t))
@ -459,7 +461,8 @@
(message-box (string-constant drscheme) (message-box (string-constant drscheme)
(if (exn? exn) (if (exn? exn)
(format "~a" (exn-message exn)) (format "~a" (exn-message exn))
(format "~s" exn))))]) (format "~s" exn))
#:dialog-mixin frame:focus-table-mixin))])
(let* ([url (string->url s-url)] (let* ([url (string->url s-url)]
[tmp-filename (make-temporary-file "tmp~a.plt")] [tmp-filename (make-temporary-file "tmp~a.plt")]
[port (get-impure-port url)] [port (get-impure-port url)]

5
collects/drracket/private/init.rkt
View File

@ -1,7 +1,8 @@
#lang racket/unit #lang racket/unit
(require string-constants (require string-constants
"drsig.rkt" "drsig.rkt"
racket/gui/base) racket/gui/base
framework)
(import) (import)
@ -50,4 +51,4 @@
(parameterize ([current-custodian system-custodian]) (parameterize ([current-custodian system-custodian])
(parameterize ([current-eventspace error-display-eventspace]) (parameterize ([current-eventspace error-display-eventspace])
(message-box title text #f '(stop ok)))))))) (message-box title text #f '(stop ok) #:dialog-mixin frame:focus-table-mixin)))))))

13
collects/drracket/private/language-configuration.rkt
View File

@ -162,7 +162,7 @@
(define language-dialog (define language-dialog
(λ (show-welcome? language-settings-to-show [parent #f]) (λ (show-welcome? language-settings-to-show [parent #f])
(define ret-dialog% (define ret-dialog%
(class dialog% (class (frame:focus-table-mixin dialog%)
(define/override (on-subwindow-char receiver evt) (define/override (on-subwindow-char receiver evt)
(case (send evt get-key-code) (case (send evt get-key-code)
[(escape) (cancel-callback)] [(escape) (cancel-callback)]
@ -170,7 +170,7 @@
[else [else
(or (key-pressed receiver evt) (or (key-pressed receiver evt)
(super on-subwindow-char receiver evt))])) (super on-subwindow-char receiver evt))]))
(super-instantiate ()))) (super-new)))
(define dialog (instantiate ret-dialog% () (define dialog (instantiate ret-dialog% ()
(label (if show-welcome? (label (if show-welcome?
@ -214,7 +214,8 @@
(define (ok-callback) (define (ok-callback)
(unless (enter-callback) (unless (enter-callback)
(message-box (string-constant drscheme) (message-box (string-constant drscheme)
(string-constant please-select-a-language)))) (string-constant please-select-a-language)
#:dialog-mixin frame:focus-table-mixin)))
;; cancel-callback : -> void ;; cancel-callback : -> void
(define (cancel-callback) (define (cancel-callback)
@ -1285,7 +1286,8 @@
(message-box (string-constant drscheme) (message-box (string-constant drscheme)
(if (exn? x) (if (exn? x)
(exn-message x) (exn-message x)
(format "uncaught exception: ~s" x))) (format "uncaught exception: ~s" x))
#:dialog-mixin frame:focus-table-mixin)
read-syntax/namespace-introduce)]) read-syntax/namespace-introduce)])
(contract (contract
(->* () (->* ()
@ -1335,7 +1337,8 @@
numberss numberss
summaries summaries
urls urls
reader-specs))]))))) reader-specs)
#:dialog-mixin frame:focus-table-mixin)])))))
(define (platform-independent-string->path str) (define (platform-independent-string->path str)
(apply (apply

15
collects/drracket/private/language.rkt
View File

@ -783,7 +783,8 @@
[(string=? "" filename-str) [(string=? "" filename-str)
(message-box (string-constant drscheme) (message-box (string-constant drscheme)
(string-constant please-specify-a-filename) (string-constant please-specify-a-filename)
dlg) dlg
#:dialog-mixin frame:focus-table-mixin)
#f] #f]
[(not (users-name-ok? mode extension dlg (string->path filename-str))) [(not (users-name-ok? mode extension dlg (string->path filename-str)))
#f] #f]
@ -797,7 +798,8 @@
(eq? (message-box (string-constant drscheme) (eq? (message-box (string-constant drscheme)
(format (string-constant are-you-sure-delete?) filename) (format (string-constant are-you-sure-delete?) filename)
dlg dlg
'(yes-no)) '(yes-no)
#:dialog-mixin frame:focus-table-mixin)
'yes)) 'yes))
(define cancelled? #t) (define cancelled? #t)
@ -904,7 +906,8 @@
[(distribution) (string-constant distribution)]) [(distribution) (string-constant distribution)])
name name
extension) extension)
parent) parent
#:dialog-mixin frame:focus-table-mixin)
#f))))) #f)))))
;; default-executable-filename : path symbol boolean -> path ;; default-executable-filename : path symbol boolean -> path
@ -940,7 +943,8 @@
(λ (x) (λ (x)
(message-box (message-box
(string-constant drscheme) (string-constant drscheme)
(format "~a" (exn-message x))) (format "~a" (exn-message x))
#:dialog-mixin frame:focus-table-mixin)
(void))]) (void))])
(define init-code-tmp-filename (make-temporary-file "drs-standalone-exectable-init~a")) (define init-code-tmp-filename (make-temporary-file "drs-standalone-exectable-init~a"))
(define bootstrap-tmp-filename (make-temporary-file "drs-standalone-exectable-bootstrap~a")) (define bootstrap-tmp-filename (make-temporary-file "drs-standalone-exectable-bootstrap~a"))
@ -1163,7 +1167,8 @@
(λ (x) (λ (x)
(message-box (message-box
(string-constant drscheme) (string-constant drscheme)
(format "~a" (exn-message x))) (format "~a" (exn-message x))
#:dialog-mixin frame:focus-table-mixin)
(void))]) (void))])
((if gui? make-mred-launcher make-mzscheme-launcher) ((if gui? make-mred-launcher make-mzscheme-launcher)

8
collects/drracket/private/rep.rkt
View File

@ -903,7 +903,7 @@ TODO
(floor (/ new-limit 1024 1024)))) (floor (/ new-limit 1024 1024))))
frame frame
'(default=1 stop) '(default=1 stop)
)]) #:dialog-mixin frame:focus-table-mixin)])
(when (equal? ans 3) (when (equal? ans 3)
(set-custodian-limit new-limit) (set-custodian-limit new-limit)
(preferences:set 'drracket:child-only-memory-limit new-limit)) (preferences:set 'drracket:child-only-memory-limit new-limit))
@ -1369,7 +1369,8 @@ TODO
#f #f
(or (get-top-level-window) (get-can-close-parent)) (or (get-top-level-window) (get-can-close-parent))
'(default=1 caution) '(default=1 caution)
2) 2
#:dialog-mixin frame:focus-table-mixin)
1)] 1)]
[(let ([user-eventspace (get-user-eventspace)]) [(let ([user-eventspace (get-user-eventspace)])
(and user-eventspace (and user-eventspace
@ -1383,7 +1384,8 @@ TODO
#f #f
(or (get-top-level-window) (get-can-close-parent)) (or (get-top-level-window) (get-can-close-parent))
'(default=1 caution) '(default=1 caution)
2) 2
#:dialog-mixin frame:focus-table-mixin)
1)] 1)]
[else #t]) [else #t])
(inner #t can-close?))) (inner #t can-close?)))

3
collects/drracket/private/syncheck/gui.rkt
View File

@ -612,7 +612,8 @@ If the namespace does not, they are colored the unbound color.
(string-constant cancel) (string-constant cancel)
#f #f
parent parent
'(stop default=2)) '(stop default=2)
#:dialog-mixin frame:focus-table-mixin)
1))) 1)))
(when do-renaming? (when do-renaming?

29
collects/drracket/private/unit.rkt
View File

@ -150,7 +150,8 @@ module browser threading seems wrong.
[else [else
(message-box (message-box
(string-constant drscheme) (string-constant drscheme)
"Must choose a filename that ends with either .png, .jpg, .xbm, or .xpm")])))))])))))) "Must choose a filename that ends with either .png, .jpg, .xbm, or .xpm"
#:dialog-mixin frame:focus-table-mixin)])))))]))))))
(void)))))) (void))))))
@ -338,7 +339,8 @@ module browser threading seems wrong.
(message-box (message-box
(string-constant drscheme) (string-constant drscheme)
v v
dlg)])))] dlg
#:dialog-mixin frame:focus-table-mixin)])))]
[cancel-callback [cancel-callback
(λ () (send dlg show #f))]) (λ () (send dlg show #f))])
(let-values ([(ok cancel) (let-values ([(ok cancel)
@ -364,7 +366,8 @@ module browser threading seems wrong.
[(not program-filename) [(not program-filename)
(message-box (string-constant create-executable-title) (message-box (string-constant create-executable-title)
(string-constant must-save-before-executable) (string-constant must-save-before-executable)
frame)] frame
#:dialog-mixin frame:focus-table-mixin)]
[else [else
(when (or (not (send definitions-text is-modified?)) (when (or (not (send definitions-text is-modified?))
(gui-utils:get-choice (gui-utils:get-choice
@ -1667,7 +1670,8 @@ module browser threading seems wrong.
(gui-utils:format-literal-label (string-constant erase-log-directory-contents) (gui-utils:format-literal-label (string-constant erase-log-directory-contents)
transcript-directory) transcript-directory)
this this
'(yes-no))]) '(yes-no)
#:dialog-mixin frame:focus-table-mixin)])
(cond (cond
[(eq? query 'no) [(eq? query 'no)
#f] #f]
@ -1680,7 +1684,8 @@ module browser threading seems wrong.
(if (exn? exn) (if (exn? exn)
(format "~a" (exn-message exn)) (format "~a" (exn-message exn))
(format "~s" exn))) (format "~s" exn)))
this) this
#:dialog-mixin frame:focus-table-mixin)
#f)]) #f)])
(for-each (λ (file) (delete-file (build-path transcript-directory file))) (for-each (λ (file) (delete-file (build-path transcript-directory file)))
dir-list) dir-list)
@ -2669,7 +2674,8 @@ module browser threading seems wrong.
#f #f
this this
'(caution default=2 number-order) '(caution default=2 number-order)
1)]) 1
#:dialog-mixin frame:focus-table-mixin)])
(case user-choice (case user-choice
[(1) (void)] [(1) (void)]
[(2) (revert)])))) [(2) (revert)]))))
@ -3177,7 +3183,8 @@ module browser threading seems wrong.
strs))]) strs))])
(unless can-browse? (unless can-browse?
(message-box (string-constant drscheme) (message-box (string-constant drscheme)
(string-constant module-browser-only-in-plt-and-module-langs))) (string-constant module-browser-only-in-plt-and-module-langs)
#:dialog-mixin frame:focus-table-mixin))
can-browse?)) can-browse?))
(define/private (update-module-browser-pane) (define/private (update-module-browser-pane)
@ -3577,7 +3584,8 @@ module browser threading seems wrong.
(send l capability-value 'drscheme:teachpack-menu-items) (send l capability-value 'drscheme:teachpack-menu-items)
(format "\n ~a" (send l get-language-name)))) (format "\n ~a" (send l get-language-name))))
(drracket:language-configuration:get-languages)))))) (drracket:language-configuration:get-languages))))))
this))])))]))) this
#:dialog-mixin frame:focus-table-mixin))])))])))
(define/private (initialize-menus) (define/private (initialize-menus)
(let* ([mb (get-menu-bar)] (let* ([mb (get-menu-bar)]
@ -4650,8 +4658,9 @@ module browser threading seems wrong.
(frame:editor-mixin (frame:editor-mixin
(frame:standard-menus-mixin (frame:standard-menus-mixin
(frame:register-group-mixin (frame:register-group-mixin
(frame:basic-mixin (frame:focus-table-mixin
frame%)))))))))))))))))) (frame:basic-mixin
frame%)))))))))))))))))))
(define-local-member-name enable-two-way-prefs) (define-local-member-name enable-two-way-prefs)
(define (make-two-way-prefs-dragable-panel% % pref-key) (define (make-two-way-prefs-dragable-panel% % pref-key)

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:%))

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)

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 ((class->interface frame%))))
(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%))

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

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].}))

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

@ -162,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<%> (frame%)]{}
@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<%>)]{
} }

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"))

10
collects/tests/drracket/no-write-and-frame-leak.rkt
View File

@ -12,12 +12,6 @@
(error who "Deleting files is not allowed"))) (error who "Deleting files is not allowed")))
void void
void)]) void)])
(fire-up-drscheme-and-run-tests
(λ ()
(define drs-frame (wait-for-drscheme-frame))
(test:menu-select "File" "Close"))))
(parameterize ([current-command-line-arguments '#()])
(fire-up-drscheme-and-run-tests (fire-up-drscheme-and-run-tests
(λ () (λ ()
(define drs-frame1 (wait-for-drscheme-frame)) (define drs-frame1 (wait-for-drscheme-frame))
@ -29,7 +23,7 @@
(define drs-tabb (make-weak-box (send drs-frame1 get-current-tab))) (define drs-tabb (make-weak-box (send drs-frame1 get-current-tab)))
(define tab-nsb (make-weak-box (send (send (send drs-frame1 get-current-tab) get-ints) get-user-namespace))) (define tab-nsb (make-weak-box (send (send (send drs-frame1 get-current-tab) get-ints) get-user-namespace)))
(test:menu-select "File" "Close Tab") (test:menu-select "File" (if (eq? (system-type) 'unix) "Close" "Close Tab"))
(sync (system-idle-evt)) (sync (system-idle-evt))
(test:menu-select "File" "New") (test:menu-select "File" "New")
@ -38,7 +32,7 @@
(define drs-frame2b (make-weak-box (wait-for-new-frame drs-frame1))) (define drs-frame2b (make-weak-box (wait-for-new-frame drs-frame1)))
(define frame2-nsb (make-weak-box (send (send (send (weak-box-value drs-frame2b) get-current-tab) get-ints) get-user-namespace))) (define frame2-nsb (make-weak-box (send (send (send (weak-box-value drs-frame2b) get-current-tab) get-ints) get-user-namespace)))
(test:menu-select "File" "Close") (test:menu-select "File" (if (eq? (system-type) 'unix) "Close" "Close Window"))
(sync (system-idle-evt)) (sync (system-idle-evt))
(let loop ([n 30]) (let loop ([n 30])

31
collects/tests/drracket/private/drracket-test-util.rkt
View File

@ -61,7 +61,7 @@
(fw:preferences:set 'framework:file-dialogs 'common) (fw:preferences:set 'framework:file-dialogs 'common)
(open-dialog) (open-dialog)
(let ([dlg (wait-for-new-frame drs)]) (let ([dlg (wait-for-new-frame drs)])
(send (find-labelled-window "Filename:") focus) (send (find-labelled-window "Filename:" #f (fw:test:get-active-top-level-window)) focus)
(fw:test:keystroke #\a (list (case (system-type) (fw:test:keystroke #\a (list (case (system-type)
[(windows) 'control] [(windows) 'control]
[(macosx macos) 'meta] [(macosx macos) 'meta]
@ -100,7 +100,7 @@
(define (wait-for-drscheme-frame [print-message? #f]) (define (wait-for-drscheme-frame [print-message? #f])
(let ([wait-for-drscheme-frame-pred (let ([wait-for-drscheme-frame-pred
(lambda () (lambda ()
(let ([active (get-top-level-focus-window)]) (let ([active (fw:test:get-active-top-level-window)])
(if (and active (if (and active
(drscheme-frame? active)) (drscheme-frame? active))
active active
@ -123,15 +123,14 @@
[(old-frame extra-eventspaces timeout) [(old-frame extra-eventspaces timeout)
(let ([wait-for-new-frame-pred (let ([wait-for-new-frame-pred
(lambda () (lambda ()
(let ([active (or (get-top-level-focus-window) (let ([active (or (fw:test:get-active-top-level-window)
(ormap (ormap
(lambda (eventspace) (lambda (eventspace)
(parameterize ([current-eventspace eventspace]) (parameterize ([current-eventspace eventspace])
(get-top-level-focus-window))) (fw:test:get-active-top-level-window)))
extra-eventspaces))]) extra-eventspaces))])
(if (and active (if (and active
(send active get-focus-window) (not (eq? active old-frame)))
(not (eq? active old-frame)))
active active
#f)))]) #f)))])
(poll-until wait-for-new-frame-pred timeout))])) (poll-until wait-for-new-frame-pred timeout))]))
@ -172,7 +171,7 @@
(define (verify-drscheme-frame-frontmost function-name frame) (define (verify-drscheme-frame-frontmost function-name frame)
(on-eventspace-handler-thread 'verify-drscheme-frame-frontmost) (on-eventspace-handler-thread 'verify-drscheme-frame-frontmost)
(let ([tl (get-top-level-focus-window)]) (let ([tl (fw:test:get-active-top-level-window)])
(unless (and (eq? frame tl) (unless (and (eq? frame tl)
(drscheme-frame? tl)) (drscheme-frame? tl))
(error function-name "drscheme frame not frontmost: ~e (found ~e)" frame tl)))) (error function-name "drscheme frame not frontmost: ~e (found ~e)" frame tl))))
@ -180,9 +179,9 @@
(define (clear-definitions frame) (define (clear-definitions frame)
(queue-callback/res (λ () (verify-drscheme-frame-frontmost 'clear-definitions frame))) (queue-callback/res (λ () (verify-drscheme-frame-frontmost 'clear-definitions frame)))
(fw:test:new-window (queue-callback/res (λ () (send frame get-definitions-canvas)))) (fw:test:new-window (queue-callback/res (λ () (send frame get-definitions-canvas))))
(let ([window (queue-callback/res (λ () (send frame get-focus-window)))]) (let ([window (queue-callback/res (λ () (send frame get-edit-target-window)))])
(let-values ([(cw ch) (queue-callback/res (λ () (send window get-client-size)))] (let-values ([(cw ch) (queue-callback/res (λ () (send window get-client-size)))]
[(w h) (queue-callback/res (λ () (send window get-size)))]) [(w h) (queue-callback/res (λ () (send window get-size)))])
(fw:test:mouse-click 'left (fw:test:mouse-click 'left
(inexact->exact (floor (+ cw (/ (- w cw) 2)))) (inexact->exact (floor (+ cw (/ (- w cw) 2))))
(inexact->exact (floor (+ ch (/ (- h ch) 2))))))) (inexact->exact (floor (+ ch (/ (- h ch) 2)))))))
@ -344,10 +343,10 @@
(andmap (lambda (x) (or string? regexp?)) in-language-spec)) (andmap (lambda (x) (or string? regexp?)) in-language-spec))
(error 'set-language-level! "expected a non-empty list of regexps and strings for language, got: ~e" in-language-spec)) (error 'set-language-level! "expected a non-empty list of regexps and strings for language, got: ~e" in-language-spec))
(not-on-eventspace-handler-thread 'set-language-level!) (not-on-eventspace-handler-thread 'set-language-level!)
(let ([drs-frame (get-top-level-focus-window)]) (let ([drs-frame (fw:test:get-active-top-level-window)])
(fw:test:menu-select "Language" "Choose Language...") (fw:test:menu-select "Language" "Choose Language...")
(let* ([language-dialog (wait-for-new-frame drs-frame)] (let* ([language-dialog (wait-for-new-frame drs-frame)]
[language-choice (find-labelled-window #f hierarchical-list%)] [language-choice (find-labelled-window #f hierarchical-list% (fw:test:get-active-top-level-window))]
[b1 (box 0)] [b1 (box 0)]
[b2 (box 0)] [b2 (box 0)]
[click-on-snip [click-on-snip
@ -411,7 +410,7 @@
drs-frame)))))))) drs-frame))))))))
(define (set-module-language! [close-dialog? #t]) (define (set-module-language! [close-dialog? #t])
(not-on-eventspace-handler-thread 'set-module-language!) (not-on-eventspace-handler-thread 'set-module-language!)
(let ([drs-frame (get-top-level-focus-window)]) (let ([drs-frame (fw:test:get-active-top-level-window)])
(fw:test:menu-select "Language" "Choose Language...") (fw:test:menu-select "Language" "Choose Language...")
(let* ([language-dialog (wait-for-new-frame drs-frame)]) (let* ([language-dialog (wait-for-new-frame drs-frame)])
(fw:test:set-radio-box-item! #rx"Use the language declared in the source") (fw:test:set-radio-box-item! #rx"Use the language declared in the source")
@ -616,7 +615,9 @@
;; been read by this point, but hopefully that won't affect much ;; been read by this point, but hopefully that won't affect much
;; of the startup of drscheme) ;; of the startup of drscheme)
(fw:preferences:restore-defaults) (fw:preferences:restore-defaults)
(fw:test:use-focus-table #t)
(thread (λ () (thread (λ ()
(let ([orig-display-handler (error-display-handler)]) (let ([orig-display-handler (error-display-handler)])
(uncaught-exception-handler (uncaught-exception-handler

9
collects/tests/drracket/repl-test.rkt
View File

@ -1201,18 +1201,21 @@ This produces an ACK message
(case language-cust (case language-cust
[(raw) (void)] [(raw) (void)]
[else [else
(define edit-target (queue-callback/res (λ () (send drscheme-frame get-edit-target-window))))
(define defs-focus? (eq? edit-target definitions-canvas))
(define ints-focus? (eq? edit-target interactions-canvas))
(cond (cond
[(eq? source-location 'definitions) [(eq? source-location 'definitions)
(unless (send definitions-canvas has-focus?) (unless defs-focus?
(fprintf (current-error-port) (fprintf (current-error-port)
"FAILED execute test for ~s\n expected definitions to have the focus\n" "FAILED execute test for ~s\n expected definitions to have the focus\n"
program))] program))]
[(eq? source-location 'interactions) [(eq? source-location 'interactions)
(unless (send interactions-canvas has-focus?) (unless ints-focus?
(fprintf (current-error-port) (fprintf (current-error-port)
"FAILED execute test for ~s\n expected interactions to have the focus\n" "FAILED execute test for ~s\n expected interactions to have the focus\n"
program))] program))]
[(queue-callback/res (λ () (send definitions-canvas has-focus?))) [defs-focus?
(let ([start (car source-location)] (let ([start (car source-location)]
[finish (cdr source-location)]) [finish (cdr source-location)])
(let* ([error-ranges (queue-callback/res (λ () (send interactions-text get-error-ranges)))] (let* ([error-ranges (queue-callback/res (λ () (send interactions-text get-error-ranges)))]

2
collects/tests/drracket/stepper-test.rkt
View File

@ -488,7 +488,7 @@
(set-definitions-to-program drs-frame program) (set-definitions-to-program drs-frame program)
(let* ([stepper-frame (start-stepper drs-frame)] (let* ([stepper-frame (start-stepper drs-frame)]
[steps (get-all-steps stepper-frame)]) [steps (get-all-steps stepper-frame)])
(test:menu-select "File" "Close") (test:menu-select "File" (if (eq? (system-type) 'unix) "Close" "Close Window"))
(let ([drs-frame1 (wait-for-new-frame stepper-frame)]) (let ([drs-frame1 (wait-for-new-frame stepper-frame)])
(unless (eq? drs-frame1 drs-frame) (unless (eq? drs-frame1 drs-frame)
(error 'step-and-extract "didn't get back to drscheme frame, got: ~e" drs-frame))) (error 'step-and-extract "didn't get back to drscheme frame, got: ~e" drs-frame)))

4
collects/tests/drracket/teaching-lang-save-file.rkt
View File

@ -30,7 +30,7 @@
(error 'save-teaching-lang-file.rkt (error 'save-teaching-lang-file.rkt
"expected the saved file to contain the word 'metadata' in a comment")) "expected the saved file to contain the word 'metadata' in a comment"))
(do-execute drr-frame) (do-execute drr-frame)
(test:menu-select "File" "Close Tab") (test:menu-select "File" (if (eq? (system-type) 'unix) "Close" "Close Tab"))
(use-get/put-dialog (use-get/put-dialog
(λ () (λ ()
(test:menu-select "File" "Open...")) (test:menu-select "File" "Open..."))
@ -40,7 +40,7 @@
drr-frame drr-frame
(send interactions-text paragraph-start-position 2) (send interactions-text paragraph-start-position 2)
(send interactions-text last-position))]) (send interactions-text last-position))])
(test:menu-select "File" "Close Tab") (test:menu-select "File" (if (eq? (system-type) 'unix) "Close" "Close Tab"))
(delete-file fn) (delete-file fn)
(unless (equal? result "1\n> ") (unless (equal? result "1\n> ")
(error 'save-teaching-lang-file.rkt "expected the program to produce 1 (followed by the prompt), got ~s" result))))))) (error 'save-teaching-lang-file.rkt "expected the program to produce 1 (followed by the prompt), got ~s" result)))))))