87 lines
3.0 KiB
Racket
87 lines
3.0 KiB
Racket
(module time-keystrokes mzscheme
|
|
|
|
(require drscheme/tool
|
|
mzlib/list
|
|
mzlib/unit
|
|
mzlib/class
|
|
mzlib/etc
|
|
mred
|
|
framework)
|
|
|
|
(provide tool@)
|
|
|
|
(define short-str "(abc)")
|
|
(define chars-to-test (build-string
|
|
400
|
|
(λ (i) (string-ref short-str (modulo i (string-length short-str))))))
|
|
|
|
(define tool@
|
|
(unit
|
|
(import drscheme:tool^)
|
|
(export drscheme:tool-exports^)
|
|
|
|
(define (phase1) (void))
|
|
(define (phase2) (void))
|
|
|
|
(define (tool-mixin super%)
|
|
(class super%
|
|
(inherit get-button-panel)
|
|
(super-new)
|
|
(let ([button (new button%
|
|
(label "Time Keystrokes")
|
|
(parent (get-button-panel))
|
|
(callback
|
|
(lambda (button evt)
|
|
(time-keystrokes this))))])
|
|
(send (get-button-panel) change-children
|
|
(lambda (l)
|
|
(cons button (remq button l)))))))
|
|
|
|
(define (time-keystrokes frame)
|
|
(let loop ([n 10])
|
|
(when (zero? n)
|
|
(error 'time-keystrokes "could not find drscheme frame"))
|
|
(let ([front-frame (test:get-active-top-level-window)])
|
|
(unless (eq? front-frame frame)
|
|
(sleep 1/10)
|
|
(loop (- n 1)))))
|
|
(let ([win (send frame get-definitions-canvas)])
|
|
(send win focus)
|
|
(time (send-key-events win chars-to-test))))
|
|
|
|
(define (send-key-events window chars)
|
|
(for-each (λ (char)
|
|
(send-key-event window (new key-event% (key-code char))))
|
|
(string->list chars)))
|
|
|
|
|
|
;; copied from framework/test.rkt
|
|
(define (send-key-event window event)
|
|
(let loop ([l (ancestor-list window #t)])
|
|
(cond [(null? l)
|
|
(cond
|
|
[(method-in-interface? 'on-char (object-interface window))
|
|
(send window on-char event)]
|
|
[(is-a? window text-field%)
|
|
(send (send window get-editor) on-char event)]
|
|
[else
|
|
(error
|
|
'send-key-event
|
|
"focused window is not a text-field% and does not have on-char: ~s" window)])]
|
|
[(send (car l) on-subwindow-char window event) #f]
|
|
[else (loop (cdr l))])))
|
|
|
|
;; copied from framework/test.rkt
|
|
(define (ancestor-list window stop-at-top-level-window?)
|
|
(let loop ([w window] [l null])
|
|
(if (or (not w)
|
|
(and stop-at-top-level-window?
|
|
(is-a? w top-level-window<%>)))
|
|
l
|
|
(loop (send w get-parent) (cons w l)))))
|
|
|
|
(when (getenv "PLTDRKEYS")
|
|
(printf "PLTDRKEYS: installing unit frame mixin\n")
|
|
(drscheme:get/extend:extend-unit-frame tool-mixin)))))
|
|
|