From b25c7cf3b118a78c00a556600e079fe40b77d1d2 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 4 Sep 2011 23:59:42 -0500 Subject: [PATCH] add frame:focus-table-mixin & related things to be able to make drracket test suites that don't depend on the OS giving any focus messages original commit: a67f509f90359203463c943e4de90eb5e8a91656 --- collects/framework/main.rkt | 26 ++++- collects/framework/private/finder.rkt | 12 ++- collects/framework/private/frame.rkt | 34 +++++-- collects/framework/private/sig.rkt | 2 + collects/framework/test.rkt | 98 ++++++++++++------- collects/scribblings/framework/frame.scrbl | 29 ++++++ .../scribblings/framework/main-extracts.rkt | 2 +- 7 files changed, 155 insertions(+), 48 deletions(-) diff --git a/collects/framework/main.rkt b/collects/framework/main.rkt index 88de9a1d..4352051f 100644 --- a/collects/framework/main.rkt +++ b/collects/framework/main.rkt @@ -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:%)) diff --git a/collects/framework/private/finder.rkt b/collects/framework/private/finder.rkt index 8b5675e9..ac020ee3 100644 --- a/collects/framework/private/finder.rkt +++ b/collects/framework/private/finder.rkt @@ -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) diff --git a/collects/framework/private/frame.rkt b/collects/framework/private/frame.rkt index b051dea8..856b7fde 100644 --- a/collects/framework/private/frame.rkt +++ b/collects/framework/private/frame.rkt @@ -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%)) diff --git a/collects/framework/private/sig.rkt b/collects/framework/private/sig.rkt index 60520eeb..aa76198d 100644 --- a/collects/framework/private/sig.rkt +++ b/collects/framework/private/sig.rkt @@ -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 diff --git a/collects/framework/test.rkt b/collects/framework/test.rkt index fe4bf793..df53fc68 100644 --- a/collects/framework/test.rkt +++ b/collects/framework/test.rkt @@ -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].})) diff --git a/collects/scribblings/framework/frame.scrbl b/collects/scribblings/framework/frame.scrbl index 571909cb..7e5a16cc 100644 --- a/collects/scribblings/framework/frame.scrbl +++ b/collects/scribblings/framework/frame.scrbl @@ -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<%>)]{ } diff --git a/collects/scribblings/framework/main-extracts.rkt b/collects/scribblings/framework/main-extracts.rkt index 44309747..6d7e7c29 100644 --- a/collects/scribblings/framework/main-extracts.rkt +++ b/collects/scribblings/framework/main-extracts.rkt @@ -1,4 +1,4 @@ -#lang scheme/base +#lang racket/base (require scribble/extract) (provide-extracted (lib "framework/main.rkt"))