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

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

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

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

@ -1,7 +1,8 @@
#lang racket/unit
(require string-constants
"drsig.rkt"
racket/gui/base)
racket/gui/base
framework)
(import)
@ -50,4 +51,4 @@
(parameterize ([current-custodian system-custodian])
(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
(λ (show-welcome? language-settings-to-show [parent #f])
(define ret-dialog%
(class dialog%
(class (frame:focus-table-mixin dialog%)
(define/override (on-subwindow-char receiver evt)
(case (send evt get-key-code)
[(escape) (cancel-callback)]
@ -170,7 +170,7 @@
[else
(or (key-pressed receiver evt)
(super on-subwindow-char receiver evt))]))
(super-instantiate ())))
(super-new)))
(define dialog (instantiate ret-dialog% ()
(label (if show-welcome?
@ -214,7 +214,8 @@
(define (ok-callback)
(unless (enter-callback)
(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
(define (cancel-callback)
@ -1285,7 +1286,8 @@
(message-box (string-constant drscheme)
(if (exn? x)
(exn-message x)
(format "uncaught exception: ~s" x)))
(format "uncaught exception: ~s" x))
#:dialog-mixin frame:focus-table-mixin)
read-syntax/namespace-introduce)])
(contract
(->* ()
@ -1335,7 +1337,8 @@
numberss
summaries
urls
reader-specs))])))))
reader-specs)
#:dialog-mixin frame:focus-table-mixin)])))))
(define (platform-independent-string->path str)
(apply

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

@ -783,7 +783,8 @@
[(string=? "" filename-str)
(message-box (string-constant drscheme)
(string-constant please-specify-a-filename)
dlg)
dlg
#:dialog-mixin frame:focus-table-mixin)
#f]
[(not (users-name-ok? mode extension dlg (string->path filename-str)))
#f]
@ -797,7 +798,8 @@
(eq? (message-box (string-constant drscheme)
(format (string-constant are-you-sure-delete?) filename)
dlg
'(yes-no))
'(yes-no)
#:dialog-mixin frame:focus-table-mixin)
'yes))
(define cancelled? #t)
@ -904,7 +906,8 @@
[(distribution) (string-constant distribution)])
name
extension)
parent)
parent
#:dialog-mixin frame:focus-table-mixin)
#f)))))
;; default-executable-filename : path symbol boolean -> path
@ -940,7 +943,8 @@
(λ (x)
(message-box
(string-constant drscheme)
(format "~a" (exn-message x)))
(format "~a" (exn-message x))
#:dialog-mixin frame:focus-table-mixin)
(void))])
(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"))
@ -1163,7 +1167,8 @@
(λ (x)
(message-box
(string-constant drscheme)
(format "~a" (exn-message x)))
(format "~a" (exn-message x))
#:dialog-mixin frame:focus-table-mixin)
(void))])
((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))))
frame
'(default=1 stop)
)])
#:dialog-mixin frame:focus-table-mixin)])
(when (equal? ans 3)
(set-custodian-limit new-limit)
(preferences:set 'drracket:child-only-memory-limit new-limit))
@ -1369,7 +1369,8 @@ TODO
#f
(or (get-top-level-window) (get-can-close-parent))
'(default=1 caution)
2)
2
#:dialog-mixin frame:focus-table-mixin)
1)]
[(let ([user-eventspace (get-user-eventspace)])
(and user-eventspace
@ -1383,7 +1384,8 @@ TODO
#f
(or (get-top-level-window) (get-can-close-parent))
'(default=1 caution)
2)
2
#:dialog-mixin frame:focus-table-mixin)
1)]
[else #t])
(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)
#f
parent
'(stop default=2))
'(stop default=2)
#:dialog-mixin frame:focus-table-mixin)
1)))
(when do-renaming?

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

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

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

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)

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

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

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

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

@ -162,6 +162,35 @@
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<%>)]{
}

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

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

@ -12,12 +12,6 @@
(error who "Deleting files is not allowed")))
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
(λ ()
(define drs-frame1 (wait-for-drscheme-frame))
@ -29,7 +23,7 @@
(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)))
(test:menu-select "File" "Close Tab")
(test:menu-select "File" (if (eq? (system-type) 'unix) "Close" "Close Tab"))
(sync (system-idle-evt))
(test:menu-select "File" "New")
@ -38,7 +32,7 @@
(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)))
(test:menu-select "File" "Close")
(test:menu-select "File" (if (eq? (system-type) 'unix) "Close" "Close Window"))
(sync (system-idle-evt))
(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)
(open-dialog)
(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)
[(windows) 'control]
[(macosx macos) 'meta]
@ -100,7 +100,7 @@
(define (wait-for-drscheme-frame [print-message? #f])
(let ([wait-for-drscheme-frame-pred
(lambda ()
(let ([active (get-top-level-focus-window)])
(let ([active (fw:test:get-active-top-level-window)])
(if (and active
(drscheme-frame? active))
active
@ -123,15 +123,14 @@
[(old-frame extra-eventspaces timeout)
(let ([wait-for-new-frame-pred
(lambda ()
(let ([active (or (get-top-level-focus-window)
(ormap
(let ([active (or (fw:test:get-active-top-level-window)
(ormap
(lambda (eventspace)
(parameterize ([current-eventspace eventspace])
(get-top-level-focus-window)))
(parameterize ([current-eventspace eventspace])
(fw:test:get-active-top-level-window)))
extra-eventspaces))])
(if (and active
(send active get-focus-window)
(not (eq? active old-frame)))
(not (eq? active old-frame)))
active
#f)))])
(poll-until wait-for-new-frame-pred timeout))]))
@ -172,7 +171,7 @@
(define (verify-drscheme-frame-frontmost function-name frame)
(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)
(drscheme-frame? tl))
(error function-name "drscheme frame not frontmost: ~e (found ~e)" frame tl))))
@ -180,9 +179,9 @@
(define (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))))
(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)))]
[(w h) (queue-callback/res (λ () (send window get-size)))])
[(w h) (queue-callback/res (λ () (send window get-size)))])
(fw:test:mouse-click 'left
(inexact->exact (floor (+ cw (/ (- w cw) 2))))
(inexact->exact (floor (+ ch (/ (- h ch) 2)))))))
@ -344,10 +343,10 @@
(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))
(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...")
(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)]
[b2 (box 0)]
[click-on-snip
@ -411,7 +410,7 @@
drs-frame))))))))
(define (set-module-language! [close-dialog? #t])
(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...")
(let* ([language-dialog (wait-for-new-frame drs-frame)])
(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
;; of the startup of drscheme)
(fw:preferences:restore-defaults)
(fw:test:use-focus-table #t)
(thread (λ ()
(let ([orig-display-handler (error-display-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
[(raw) (void)]
[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
[(eq? source-location 'definitions)
(unless (send definitions-canvas has-focus?)
(unless defs-focus?
(fprintf (current-error-port)
"FAILED execute test for ~s\n expected definitions to have the focus\n"
program))]
[(eq? source-location 'interactions)
(unless (send interactions-canvas has-focus?)
(unless ints-focus?
(fprintf (current-error-port)
"FAILED execute test for ~s\n expected interactions to have the focus\n"
program))]
[(queue-callback/res (λ () (send definitions-canvas has-focus?)))
[defs-focus?
(let ([start (car source-location)]
[finish (cdr source-location)])
(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)
(let* ([stepper-frame (start-stepper drs-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)])
(unless (eq? drs-frame1 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
"expected the saved file to contain the word 'metadata' in a comment"))
(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
(λ ()
(test:menu-select "File" "Open..."))
@ -40,7 +40,7 @@
drr-frame
(send interactions-text paragraph-start-position 2)
(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)
(unless (equal? result "1\n> ")
(error 'save-teaching-lang-file.rkt "expected the program to produce 1 (followed by the prompt), got ~s" result)))))))