suzanne.soy/gui
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

original commit: a67f509f90359203463c943e4de90eb5e8a91656
This commit is contained in:
Robby Findler 2011-09-04 23:59:42 -05:00
parent d1798aa1c1
commit b25c7cf3b1
7 changed files with 155 additions and 48 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:%))

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