diff --git a/collects/framework/main.rkt b/collects/framework/main.rkt index c55824ae..c383944b 100644 --- a/collects/framework/main.rkt +++ b/collects/framework/main.rkt @@ -72,6 +72,12 @@ in a GUI, and the color to use. The colors are used to show the nesting structure in the parens.}) + (thing-doc + color:misspelled-text-color-style-name + string? + @{The name of the style used to color misspelled words. See also + @method[color:text<%> get-spell-check-strings].}) + (proc-doc/names text:range? (-> any/c boolean?) (arg) @{Determines if @racket[arg] is an instance of the @tt{range} struct.}) diff --git a/collects/framework/private/aspell.rkt b/collects/framework/private/aspell.rkt index 42378eee..4c5eddcd 100644 --- a/collects/framework/private/aspell.rkt +++ b/collects/framework/private/aspell.rkt @@ -1,11 +1,14 @@ #lang racket/base (require racket/system racket/match - racket/contract) + racket/contract + racket/port + string-constants) (provide/contract [query-aspell (-> (and/c string? (not/c #rx"[\n]")) (listof (list/c number? number?)))] - [find-aspell-binary-path (-> (or/c path? #f))]) + [find-aspell-binary-path (-> (or/c path? #f))] + [aspell-problematic? (-> (or/c string? #f))]) (define aspell-candidate-paths '("/usr/bin" @@ -25,6 +28,41 @@ (and (file-exists? c2) c2))))) +(define (start-aspell asp) + (define aspell? (regexp-match? #rx"aspell" (path->string asp))) + (apply process* asp "-a" (if aspell? '("--encoding=utf-8") '()))) + +(define (aspell-problematic?) + (define asp (find-aspell-binary-path)) + (cond + [(not asp) + (string-constant cannot-find-ispell-or-aspell-path)] + [else + (define proc-lst (start-aspell asp)) + (define stdout (list-ref proc-lst 0)) + (define stderr (list-ref proc-lst 3)) + (close-output-port (list-ref proc-lst 1)) ;; close stdin + (close-input-port stdout) + (define sp (open-output-string)) + (copy-port stderr sp) + (define errmsg (get-output-string sp)) + (close-input-port stderr) + (cond + [(not (equal? errmsg "")) + (string-append + (format (string-constant spell-program-wrote-to-stderr-on-startup) asp) + "\n\n" + errmsg)] + [else #f])])) + +(define asp-logger (make-logger 'framework/aspell (current-logger))) +(define-syntax-rule + (asp-log arg) + (when (log-level? asp-logger 'debug) + (asp-log/proc arg))) +(define (asp-log/proc arg) + (log-message asp-logger 'debug arg (current-continuation-marks))) + (define aspell-req-chan (make-channel)) (define aspell-thread #f) (define (start-aspell-thread) @@ -40,12 +78,13 @@ (set! already-attempted-aspell? #t) (define asp (find-aspell-binary-path)) (when asp - (define aspell? (regexp-match? #rx"aspell" (path->string asp))) - (set! aspell-proc (apply process* asp "-a" (if aspell? '("--encoding=utf-8") '()))) - (define line (read-line (list-ref aspell-proc 0))) - (log-info (format "framework: started speller: ~a" line)) + (set! aspell-proc (start-aspell asp)) + (define line (with-handlers ((exn:fail? exn-message)) + (read-line (list-ref aspell-proc 0)))) + (asp-log (format "framework: started speller: ~a" line)) - (when (regexp-match #rx"[Aa]spell" line) + (when (and (string? line) + (regexp-match #rx"[Aa]spell" line)) ;; put aspell in "terse" mode (display "!\n" (list-ref aspell-proc 1)) (flush-output (list-ref aspell-proc 1))) @@ -57,11 +96,11 @@ (define l (with-handlers ((exn:fail? void)) (read-line stderr))) (when (string? l) - (log-warning (format "aspell-proc stderr: ~a" l)) + (asp-log (format "aspell-proc stderr: ~a" l)) (loop)))))))) (define (shutdown-aspell why) - (log-warning (format "aspell.rkt: shutdown connection to aspell: ~a" why)) + (asp-log (format "aspell.rkt: shutdown connection to aspell: ~a" why)) (define proc (list-ref aspell-proc 4)) (close-input-port (list-ref aspell-proc 0)) (close-output-port (list-ref aspell-proc 1)) @@ -94,7 +133,12 @@ (define check-on-aspell (sync/timeout .5 stdout)) (cond [check-on-aspell - (define l (read-line stdout)) + (define l (with-handlers ((exn:fail? (λ (x) + (asp-log + (format "error reading stdout of aspell process: ~a" + (exn-message x))) + eof))) + (read-line stdout))) (cond [(eof-object? l) (send-resp '()) diff --git a/collects/framework/private/color.rkt b/collects/framework/private/color.rkt index ed3196ef..1879642e 100644 --- a/collects/framework/private/color.rkt +++ b/collects/framework/private/color.rkt @@ -6,9 +6,8 @@ added reset-regions added get-regions |# -(require mzlib/class - mzlib/thread - mred +(require racket/class + racket/gui/base syntax-color/token-tree syntax-color/paren-tree syntax-color/default-lexer @@ -237,13 +236,11 @@ added get-regions (start-colorer token-sym->style get-token pairs))) ;; ---------------------- Multi-threading --------------------------- - ;; A list of (vector style number number) that indicate how to color the buffer - (define colorings null) - ;; The coroutine object for tokenizing the buffer - (define tok-cor #f) - ;; The editor revision when tok-cor was created - (define rev #f) - + ;; The editor revision when the last coloring was started + (define revision-when-started-parsing #f) + + ;; The editor revision when after the last edit to the buffer + (define revision-after-last-edit #f) (inherit change-style begin-edit-sequence end-edit-sequence highlight-range get-style-list in-edit-sequence? get-start-position get-end-position @@ -275,17 +272,7 @@ added get-regions (update-lexer-state-observers) (set! restart-callback #f) (set! force-recolor-after-freeze #f) - (set! colorings null) - (when tok-cor - (coroutine-kill tok-cor)) - (set! tok-cor #f) - (set! rev #f)) - - ;; Actually color the buffer. - (define/private (color) - (for ([clr (in-list colorings)]) - (change-style (vector-ref clr 0) (vector-ref clr 1) (vector-ref clr 2) #f)) - (set! colorings '())) + (set! revision-when-started-parsing #f)) ;; Discard extra tokens at the first of invalid-tokens (define/private (sync-invalid ls) @@ -302,60 +289,83 @@ added get-regions (set-lexer-state-invalid-tokens-mode! ls mode)) (sync-invalid ls)))) - (define/private (re-tokenize ls in in-start-pos in-lexer-mode enable-suspend) - (enable-suspend #f) - ;(define-values (_line1 _col1 pos-before) (port-next-location in)) - (define-values (lexeme type data new-token-start new-token-end backup-delta new-lexer-mode) - (get-token in in-start-pos in-lexer-mode)) - ;(define-values (_line2 _col2 pos-after) (port-next-location in)) - (enable-suspend #t) - (unless (eq? 'eof type) - (unless (exact-nonnegative-integer? new-token-start) - (error 'color:text<%> "expected an exact nonnegative integer for the token start, got ~e" new-token-start)) - (unless (exact-nonnegative-integer? new-token-end) - (error 'color:text<%> "expected an exact nonnegative integer for the token end, got ~e" new-token-end)) - (unless (exact-nonnegative-integer? backup-delta) - (error 'color:text<%> "expected an exact nonnegative integer for the backup delta, got ~e" backup-delta)) - (unless (0 . < . (- new-token-end new-token-start)) - (error 'color:text<%> "expected the distance between the start and end position for each token to be positive, but start was ~e and end was ~e" new-token-start new-token-end)) - (enable-suspend #f) - #; (printf "~s at ~a to ~a\n" lexeme (+ in-start-pos (sub1 new-token-start)) - (+ in-start-pos (sub1 new-token-end))) - (let ((len (- new-token-end new-token-start))) - #; - (unless (= len (- pos-after pos-before)) - ;; this check requires the two calls to port-next-location to be also uncommented - ;; when this check fails, bad things can happen non-deterministically later on - (eprintf "pos changed bad ; len ~s pos-before ~s pos-after ~s (token ~s mode ~s)\n" - len pos-before pos-after lexeme new-lexer-mode)) - (set-lexer-state-current-pos! ls (+ len (lexer-state-current-pos ls))) - (set-lexer-state-current-lexer-mode! ls new-lexer-mode) - (sync-invalid ls) - (when (and should-color? (should-color-type? type) (not frozen?)) - (add-colorings type in-start-pos new-token-start new-token-end)) - ;; Using the non-spec version takes 3 times as long as the spec - ;; version. In other words, the new greatly outweighs the tree - ;; operations. - ;;(insert-last! tokens (new token-tree% (length len) (data type))) - (insert-last-spec! (lexer-state-tokens ls) len (make-data type new-lexer-mode backup-delta)) - #; (show-tree (lexer-state-tokens ls)) - (send (lexer-state-parens ls) add-token data len) - (cond - [(and (not (send (lexer-state-invalid-tokens ls) is-empty?)) - (= (lexer-state-invalid-tokens-start ls) - (lexer-state-current-pos ls)) - (equal? new-lexer-mode - (lexer-state-invalid-tokens-mode ls))) - (send (lexer-state-invalid-tokens ls) search-max!) - (send (lexer-state-parens ls) merge-tree - (send (lexer-state-invalid-tokens ls) get-root-end-position)) - (insert-last! (lexer-state-tokens ls) - (lexer-state-invalid-tokens ls)) - (set-lexer-state-invalid-tokens-start! ls +inf.0) - (enable-suspend #t)] - [else - (enable-suspend #t) - (re-tokenize ls in in-start-pos new-lexer-mode enable-suspend)])))) + (define/private (re-tokenize-move-to-next-ls start-time did-something?) + (cond + [(null? re-tokenize-lses) + ;; done: return #t + #t] + [else + (define ls (car re-tokenize-lses)) + (set! re-tokenize-lses (cdr re-tokenize-lses)) + (define in + (open-input-text-editor this + (lexer-state-current-pos ls) + (lexer-state-end-pos ls) + (λ (x) #f))) + (port-count-lines! in) + (continue-re-tokenize start-time did-something? ls in + (lexer-state-current-pos ls) + (lexer-state-current-lexer-mode ls))])) + + (define re-tokenize-lses #f) + + (define/private (continue-re-tokenize start-time did-something? ls in in-start-pos lexer-mode) + (cond + [(and did-something? ((+ start-time 20.0) . <= . (current-inexact-milliseconds))) + #f] + [else + ;(define-values (_line1 _col1 pos-before) (port-next-location in)) + (define-values (lexeme type data new-token-start new-token-end backup-delta new-lexer-mode) + (get-token in in-start-pos lexer-mode)) + ;(define-values (_line2 _col2 pos-after) (port-next-location in)) + (cond + [(eq? 'eof type) + (re-tokenize-move-to-next-ls start-time #t)] + [else + (unless (exact-nonnegative-integer? new-token-start) + (error 'color:text<%> "expected an exact nonnegative integer for the token start, got ~e" new-token-start)) + (unless (exact-nonnegative-integer? new-token-end) + (error 'color:text<%> "expected an exact nonnegative integer for the token end, got ~e" new-token-end)) + (unless (exact-nonnegative-integer? backup-delta) + (error 'color:text<%> "expected an exact nonnegative integer for the backup delta, got ~e" backup-delta)) + (unless (new-token-start . < . new-token-end) + (error 'color:text<%> + "expected the distance between the start and end position for each token to be positive, but start was ~e and end was ~e" + new-token-start new-token-end)) + (let ((len (- new-token-end new-token-start))) + #; + (unless (= len (- pos-after pos-before)) + ;; this check requires the two calls to port-next-location to be also uncommented + ;; when this check fails, bad things can happen non-deterministically later on + (eprintf "pos changed bad ; len ~s pos-before ~s pos-after ~s (token ~s mode ~s)\n" + len pos-before pos-after lexeme new-lexer-mode)) + (set-lexer-state-current-pos! ls (+ len (lexer-state-current-pos ls))) + (set-lexer-state-current-lexer-mode! ls new-lexer-mode) + (sync-invalid ls) + (when (and should-color? (should-color-type? type) (not frozen?)) + (add-colorings type in-start-pos new-token-start new-token-end)) + ;; Using the non-spec version takes 3 times as long as the spec + ;; version. In other words, the new greatly outweighs the tree + ;; operations. + ;;(insert-last! tokens (new token-tree% (length len) (data type))) + (insert-last-spec! (lexer-state-tokens ls) len (make-data type new-lexer-mode backup-delta)) + #; (show-tree (lexer-state-tokens ls)) + (send (lexer-state-parens ls) add-token data len) + (cond + [(and (not (send (lexer-state-invalid-tokens ls) is-empty?)) + (= (lexer-state-invalid-tokens-start ls) + (lexer-state-current-pos ls)) + (equal? new-lexer-mode + (lexer-state-invalid-tokens-mode ls))) + (send (lexer-state-invalid-tokens ls) search-max!) + (send (lexer-state-parens ls) merge-tree + (send (lexer-state-invalid-tokens ls) get-root-end-position)) + (insert-last! (lexer-state-tokens ls) + (lexer-state-invalid-tokens ls)) + (set-lexer-state-invalid-tokens-start! ls +inf.0) + (re-tokenize-move-to-next-ls start-time #t)] + [else + (continue-re-tokenize start-time #t ls in in-start-pos new-lexer-mode)]))])])) (define/private (add-colorings type in-start-pos new-token-start new-token-end) (define sp (+ in-start-pos (sub1 new-token-start))) @@ -376,22 +386,23 @@ added get-regions [lp 0]) (cond [(null? spellos) - (set! colorings (cons (vector color (+ sp lp) (+ sp (string-length str))) - colorings))] + (add-coloring color (+ sp lp) (+ sp (string-length str)))] [else (define err (car spellos)) (define err-start (list-ref err 0)) (define err-len (list-ref err 1)) - (set! colorings (list* (vector color (+ pos lp) (+ pos err-start)) - (vector misspelled-color (+ pos err-start) (+ pos err-start err-len)) - colorings)) + (add-coloring misspelled-color (+ pos err-start) (+ pos err-start err-len)) + (add-coloring color (+ pos lp) (+ pos err-start)) (loop (cdr spellos) (+ err-start err-len))])) (loop (cdr strs) (+ pos (string-length str) 1))))] [else - (set! colorings (cons (vector color sp ep) colorings))])] + (add-coloring color sp ep)])] [else - (set! colorings (cons (vector color sp ep) colorings))])) + (add-coloring color sp ep)])) + + (define/private (add-coloring color sp ep) + (change-style color sp ep #f)) (define/private (show-tree t) (printf "Tree:\n") @@ -486,52 +497,19 @@ added get-regions (define/private (colorer-driver) (unless (andmap lexer-state-up-to-date? lexer-states) - #;(printf "revision ~a\n" (get-revision-number)) - (unless (and tok-cor (= rev (get-revision-number))) - (when tok-cor - (coroutine-kill tok-cor)) - #;(printf "new coroutine\n") - (set! tok-cor - (coroutine - (λ (enable-suspend) - (parameterize ((port-count-lines-enabled #t)) - (for-each - (lambda (ls) - (re-tokenize ls - (begin - (enable-suspend #f) - (begin0 - (open-input-text-editor this - (lexer-state-current-pos ls) - (lexer-state-end-pos ls) - (λ (x) #f)) - (enable-suspend #t))) - (lexer-state-current-pos ls) - (lexer-state-current-lexer-mode ls) - enable-suspend)) - lexer-states))))) - (set! rev (get-revision-number))) - (with-handlers ((exn:fail? - (λ (exn) - (parameterize ((print-struct #t)) - ((error-display-handler) - (format "exception in colorer thread: ~s" exn) - exn)) - (set! tok-cor #f)))) - #;(printf "begin lexing\n") - (when (coroutine-run 10 tok-cor) - (for-each (lambda (ls) - (set-lexer-state-up-to-date?! ls #t)) - lexer-states) - (update-lexer-state-observers))) - #;(printf "end lexing\n") - #;(printf "begin coloring\n") - ;; This edit sequence needs to happen even when colors is null - ;; for the paren highlighter. (begin-edit-sequence #f #f) - (color) + (c-log "starting to color") + (set! re-tokenize-lses lexer-states) + (define finished? (re-tokenize-move-to-next-ls (current-inexact-milliseconds) #f)) + (c-log (format "coloring stopped ~a" (if finished? "because it finished" "with more to do"))) + (when finished? + (for ([ls (in-list lexer-states)]) + (set-lexer-state-up-to-date?! ls #t)) + (update-lexer-state-observers) + (c-log "updated observers")) + (c-log "starting end-edit-sequence") (end-edit-sequence) - #;(printf "end coloring\n"))) + (c-log "finished end-edit-sequence"))) (define/private (colorer-callback) (cond @@ -1148,3 +1126,9 @@ added get-regions (define text-mode% (text-mode-mixin mode:surrogate-text%)) (define misspelled-text-color-style-name "Misspelled Text") + +(define logger (make-logger 'framework/colorer (current-logger))) +(define-syntax-rule + (c-log exp) + (when (log-level? logger 'debug) + (log-message logger 'debug exp (current-inexact-milliseconds)))) diff --git a/collects/framework/private/follow-log.rkt b/collects/framework/private/follow-log.rkt new file mode 100644 index 00000000..fbf4f7a0 --- /dev/null +++ b/collects/framework/private/follow-log.rkt @@ -0,0 +1,225 @@ +#lang racket/base + +(require racket/list + racket/class + racket/match + racket/pretty + racket/gui/base + framework/private/logging-timer) + +#| + +This file sets up a log receiver and then +starts up DrRacket. It catches log messages and +organizes them on event boundaries, printing +out the ones that take the longest +(possibly dropping those where a gc occurs) + +The result shows, for each gui event, the +log messages that occured during its dynamic +extent as well as the number of milliseconds +from the start of the gui event before the +log message was reported. + +|# + + +(define lr (make-log-receiver (current-logger) + 'debug 'racket/engine + 'debug 'GC + 'debug 'gui-event + 'debug 'framework/colorer + 'debug 'timeline)) + +(define top-n-events 50) +(define drop-gc? #t) +(define start-right-away? #f) + +(define log-done-chan (make-channel)) +(define bt-done-chan (make-channel)) + +(define start-log-chan (make-channel)) +(void + (thread + (λ () + (let loop () + (sync start-log-chan) + (let loop ([events '()]) + (sync + (handle-evt + lr + (λ (info) + (loop (cons info events)))) + (handle-evt + log-done-chan + (λ (resp-chan) + (channel-put resp-chan events))))) + (loop))))) + +(define thread-to-watch (current-thread)) +(let ([win (get-top-level-windows)]) + (unless (null? win) + (define fr-thd (eventspace-handler-thread (send (car win) get-eventspace))) + (unless (eq? thread-to-watch fr-thd) + (eprintf "WARNING: current-thread and eventspace thread aren't the same thread\n")))) +(define start-bt-chan (make-channel)) +(void + (thread + (λ () + (let loop () + (sync start-bt-chan) + (let loop ([marks '()]) + (sync + (handle-evt + (alarm-evt (+ (current-inexact-milliseconds) 10)) + (λ (_) + (loop (cons (continuation-marks thread-to-watch) + marks)))) + (handle-evt + bt-done-chan + (λ (resp-chan) + (define stacks (map continuation-mark-set->context marks)) + (channel-put resp-chan stacks))))) + (loop))))) + +(define controller-frame-eventspace (make-eventspace)) +(define f (parameterize ([current-eventspace controller-frame-eventspace]) + (new frame% [label "Log Follower"]))) +(define sb (new button% [label "Start Following Log"] [parent f] + [callback + (λ (_1 _2) + (sb-callback))])) +(define sb2 (new button% [label "Start Collecting Backtraces"] [parent f] + [callback + (λ (_1 _2) + (start-bt-callback))])) +(define db (new button% [label "Stop && Dump"] [parent f] [enabled #f] + [callback + (λ (_1 _2) + (cond + [following-log? + (define resp (make-channel)) + (channel-put log-done-chan resp) + (show-results (channel-get resp)) + (send db enable #f) + (send sb enable #t) + (send sb2 enable #t) + (set! following-log? #f)] + [following-bt? + (define resp (make-channel)) + (channel-put bt-done-chan resp) + (define stacks (channel-get resp)) + (show-bt-results stacks) + (send db enable #f) + (send sb enable #t) + (send sb2 enable #t) + (set! following-bt? #f)]))])) + +(define following-log? #f) +(define following-bt? #f) + +(define (sb-callback) + (set! following-log? #t) + (send sb enable #f) + (send sb2 enable #f) + (send db enable #t) + (channel-put start-log-chan #t)) + +(define (start-bt-callback) + (set! following-bt? #t) + (send sb enable #f) + (send sb2 enable #f) + (send db enable #t) + (channel-put start-bt-chan #t)) + +(send f show #t) + +(define (show-bt-results stacks) + (define top-frame (make-hash)) + (for ([stack (in-list stacks)]) + (unless (null? stack) + (define k (car stack)) + (hash-set! top-frame k (cons stack (hash-ref top-frame k '()))))) + (define sorted (sort (hash-map top-frame (λ (x y) y)) > #:key length)) + (printf "top 10: ~s\n" (map length (take sorted (min (length sorted) 10)))) + (define most-popular (cadr sorted)) + (for ([x (in-range 10)]) + (printf "---- next stack\n") + (pretty-print (list-ref most-popular (random (length most-popular)))) + (printf "\n")) + (void)) + +(struct gui-event (start end name) #:prefab) + +(define (show-results evts) + (define gui-events (filter (λ (x) + (define i (vector-ref x 2)) + (and (gui-event? i) + (number? (gui-event-end i)))) + evts)) + (define interesting-gui-events + (take (sort gui-events > #:key (λ (x) + (define i (vector-ref x 2)) + (- (gui-event-end i) + (gui-event-start i)))) + top-n-events)) + + (define with-other-events + (for/list ([gui-evt (in-list interesting-gui-events)]) + (match (vector-ref gui-evt 2) + [(gui-event start end name) + (define in-the-middle + (append (map (λ (x) (list (list 'δ (- (get-start-time x) start)) x)) + (sort + (filter (λ (x) (and (not (gui-event? (vector-ref x 2))) + (<= start (get-start-time x) end))) + evts) + < + #:key get-start-time)) + (list (list (list 'δ (- end start)) 'end-of-gui-event)))) + (list* (- end start) + gui-evt + in-the-middle)]))) + + (define (has-a-gc-event? x) + (define in-the-middle (cddr x)) + (ormap (λ (x) + (and (vector? (list-ref x 1)) + (gc-info? (vector-ref (list-ref x 1) 2)))) + in-the-middle)) + + (pretty-print + (if drop-gc? + (filter (λ (x) (not (has-a-gc-event? x))) + with-other-events) + with-other-events))) + +(struct gc-info (major? pre-amount pre-admin-amount code-amount + post-amount post-admin-amount + start-process-time end-process-time + start-time end-time) + #:prefab) +(struct engine-info (msec name) #:prefab) + +(define (get-start-time x) + (cond + [(gc-info? (vector-ref x 2)) + (gc-info-start-time (vector-ref x 2))] + [(engine-info? (vector-ref x 2)) + (engine-info-msec (vector-ref x 2))] + [(regexp-match #rx"framework" (vector-ref x 1)) + (vector-ref x 2)] + [(timeline-info? (vector-ref x 2)) + (timeline-info-milliseconds (vector-ref x 2))] + [else + (unless (regexp-match #rx"^GC: 0:MST @" (vector-ref x 1)) + (eprintf "unk: ~s\n" x)) + 0])) + + +(module+ main + (when start-right-away? + (parameterize ([current-eventspace controller-frame-eventspace]) + (queue-callback sb-callback))) + (dynamic-require 'drracket #f)) + diff --git a/collects/framework/private/frame.rkt b/collects/framework/private/frame.rkt index 215dab07..1464406f 100644 --- a/collects/framework/private/frame.rkt +++ b/collects/framework/private/frame.rkt @@ -796,9 +796,14 @@ [ec (new position-canvas% [parent panel] [button-up - (λ () - (collect-garbage) - (update-memory-text))] + (λ (evt) + (cond + [(or (send evt get-alt-down) + (send evt get-control-down)) + (dynamic-require 'framework/private/follow-log #f)] + [else + (collect-garbage) + (update-memory-text)]))] [init-width "99.99 MB"])]) (set! memory-canvases (cons ec memory-canvases)) (update-memory-text) @@ -890,6 +895,7 @@ (inherit min-client-height min-client-width get-dc get-client-size refresh) (init init-width) (init-field [button-up #f]) + (init-field [char-typed void]) (define str "") (define/public (set-str _str) (set! str _str) @@ -913,7 +919,11 @@ (let-values ([(cw ch) (get-client-size)]) (when (and (<= (send evt get-x) cw) (<= (send evt get-y) ch)) - (button-up)))))) + (if (procedure-arity-includes? button-up 1) + (button-up evt) + (button-up))))))) + (define/override (on-char evt) + (char-typed evt)) (super-new (style '(transparent no-focus))) (let ([dc (get-dc)]) (let-values ([(_1 th _2 _3) (send dc get-text-extent str)]) diff --git a/collects/framework/private/keymap.rkt b/collects/framework/private/keymap.rkt index 4c9fdd0e..21042cda 100644 --- a/collects/framework/private/keymap.rkt +++ b/collects/framework/private/keymap.rkt @@ -337,7 +337,7 @@ [mouse-popup-menu (λ (edit event) - (when (send event button-down?) + (when (send event button-up?) (let ([a (send edit get-admin)]) (when a (let ([m (make-object popup-menu%)]) @@ -739,7 +739,7 @@ (send edit on-char event) (loop (sub1 n))))) (λ () - (send edit end-edit-sequence))))))) + (send edit end-edit-sequence))))))) #t)) (send km set-break-sequence-callback done) #t))] @@ -823,7 +823,7 @@ (λ (edit event) (when building-macro (set! current-macro (reverse building-macro)) - (set! build-protect? #f) + (set! build-protect? #f) (send build-macro-km break-sequence)) #t)] [delete-key diff --git a/collects/framework/private/logging-timer.rkt b/collects/framework/private/logging-timer.rkt new file mode 100644 index 00000000..0c9ad724 --- /dev/null +++ b/collects/framework/private/logging-timer.rkt @@ -0,0 +1,66 @@ +#lang racket/base + +(require racket/gui/base + racket/class + (for-syntax racket/base)) + +(define timeline-logger (make-logger 'timeline (current-logger))) + +(provide logging-timer% + (struct-out timeline-info) + log-timeline) + +(define logging-timer% + (class timer% + (init notify-callback) + (define name (object-name notify-callback)) + (define wrapped-notify-callback + (λ () + (log-timeline + (format "~a timer fired" name) + (notify-callback)))) + (super-new [notify-callback wrapped-notify-callback]) + (define/override (start msec [just-once? #f]) + (log-timeline (format "~a timer started; msec ~s just-once? ~s" name msec just-once?)) + (super start msec just-once?)))) + + +(define-syntax (log-timeline stx) + (syntax-case stx () + [(_ info-string expr) + #'(log-timeline/proc + (and (log-level? timeline-logger 'debug) + info-string) + (λ () expr))] + [(_ info-string) + #'(log-timeline/proc + (and (log-level? timeline-logger 'debug) + info-string) + #f)])) + +(define (log-timeline/proc info expr) + (define start-time (current-inexact-milliseconds)) + (when info + (log-message timeline-logger 'debug + (format "~a start" info) + (timeline-info (if expr 'start 'once) + (current-process-milliseconds) + start-time))) + (when expr + (begin0 + (expr) + (when info + (define end-time (current-inexact-milliseconds)) + (log-message timeline-logger 'debug + (format "~a end; delta ms ~a" info (- end-time start-time)) + (timeline-info start-time + end-time + (current-inexact-milliseconds))))))) + + +;; what : (or/c 'start 'once flonum) +;; flonum means that this is an 'end' event and there should be +;; a start event corresponding to it with that milliseconds +;; process-milliseconds : fixnum +;; milliseconds : flonum -- time of this event +(struct timeline-info (what process-milliseconds milliseconds) #:transparent) diff --git a/collects/framework/private/racket.rkt b/collects/framework/private/racket.rkt index 92f1af66..12bc1388 100644 --- a/collects/framework/private/racket.rkt +++ b/collects/framework/private/racket.rkt @@ -538,7 +538,7 @@ #f)] [last-para (and last (position-paragraph last))]) - (letrec + (letrec ([find-offset (λ (start-pos) (define tab-char? #f) diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index 9e8d8d7a..0ed33675 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -11,7 +11,8 @@ "autocomplete.rkt" mred/mred-sig mrlib/interactive-value-port - racket/list) + racket/list + "logging-timer.rkt") (require setup/xref scribble/xref scribble/manual-struct) @@ -1063,7 +1064,7 @@ (when searching-str (unless timer (set! timer - (new timer% + (new logging-timer% [notify-callback (λ () (run-after-edit-sequence @@ -1536,7 +1537,7 @@ ;; have not yet been propogated to the delegate (define todo '()) - (define timer (new timer% + (define timer (new logging-timer% [notify-callback (λ () ;; it should be the case that todo is always '() when the delegate is #f @@ -3854,7 +3855,9 @@ designates the character that triggers autocompletion ;; draws line numbers on the left hand side of a text% object (define line-numbers-mixin (mixin ((class->interface text%) editor:standard-style-list<%>) (line-numbers<%>) - (inherit get-visible-line-range + (inherit begin-edit-sequence + end-edit-sequence + get-visible-line-range get-visible-position-range last-line line-location @@ -4193,6 +4196,7 @@ designates the character that triggers autocompletion (when (showing-line-numbers?) (define dc (get-dc)) (when dc + (begin-edit-sequence #f #f) (define bx (box 0)) (define by (box 0)) (define tw (text-width dc (number-space+1))) @@ -4208,7 +4212,8 @@ designates the character that triggers autocompletion tw th) (unless (= line (last-line)) - (loop (+ line 1)))))))) + (loop (+ line 1))))) + (end-edit-sequence)))) (super-new) (setup-padding))) diff --git a/collects/framework/test.rkt b/collects/framework/test.rkt index 87845539..855cac02 100644 --- a/collects/framework/test.rkt +++ b/collects/framework/test.rkt @@ -253,22 +253,26 @@ (define object-tag 'test:find-object) -;; find-object : class (union string (object -> boolean)) -> object +;; find-object : class (union string regexp (object -> boolean)) -> object (define (find-object obj-class b-desc) (λ () (cond [(or (string? b-desc) + (regexp? b-desc) (procedure? b-desc)) (let* ([active-frame (test:get-active-top-level-window)] [_ (unless active-frame (error object-tag - "could not find object: ~a, no active frame" + "could not find object: ~e, no active frame" b-desc))] [child-matches? (λ (child) (cond [(string? b-desc) (equal? (send child get-label) b-desc)] + [(regexp? b-desc) + (and (send child get-label) + (regexp-match? b-desc (send child get-label)))] [(procedure? b-desc) (b-desc child)]))] [found @@ -287,13 +291,13 @@ (send panel get-children)))]) (or found (error object-tag - "no object of class ~a named ~e in active frame" + "no object of class ~e named ~e in active frame" obj-class b-desc)))] [(is-a? b-desc obj-class) b-desc] [else (error object-tag - "expected either a string or an object of class ~a as input, received: ~a" + "expected either a string or an object of class ~e as input, received: ~e" obj-class b-desc)]))) @@ -317,7 +321,7 @@ [else (update-control ctrl) (send ctrl command event) - (void)])))))) + (void)])))))) ;; ;; BUTTON @@ -936,7 +940,8 @@ (proc-doc/names test:keystroke (->* ((or/c char? symbol?)) - ((listof (symbols 'alt 'control 'meta 'shift 'noalt 'nocontrol 'nometea 'noshift))) + ((listof (or/c 'alt 'control 'meta 'shift + 'noalt 'nocontrol 'nometea 'noshift))) void?) ((key) ((modifier-list null))) @@ -973,10 +978,11 @@ (proc-doc/names test:mouse-click (->* - ((symbols 'left 'middle 'right) + ((or/c 'left 'middle 'right) (and/c exact? integer?) (and/c exact? integer?)) - ((listof (symbols 'alt 'control 'meta 'shift 'noalt 'nocontrol 'nometa 'noshift))) + ((listof (or/c 'alt 'control 'meta 'shift 'noalt + 'nocontrol 'nometa 'noshift))) void?) ((button x y) ((modifiers null))) @@ -985,7 +991,7 @@ @method[canvas<%> on-event] method. Use @racket[test:button-push] to click on a button. - On the Macintosh, @racket['right] corresponds to holding down the command + Under Mac OS X, @racket['right] corresponds to holding down the command modifier key while clicking and @racket['middle] cannot be generated. Under Windows, @racket['middle] can only be generated if the user has a diff --git a/collects/mred/mred-sig.rkt b/collects/mred/mred-sig.rkt index bc49ba6e..8d7ecd83 100644 --- a/collects/mred/mred-sig.rkt +++ b/collects/mred/mred-sig.rkt @@ -78,6 +78,7 @@ frame% gauge% get-choices-from-user get-color-from-user +get-current-mouse-state get-default-shortcut-prefix get-directory get-display-count diff --git a/collects/mred/private/moredialogs.rkt b/collects/mred/private/moredialogs.rkt index bec55f36..d3bc8c06 100644 --- a/collects/mred/private/moredialogs.rkt +++ b/collects/mred/private/moredialogs.rkt @@ -329,7 +329,7 @@ (send blue get-value)))] [install-color (lambda (color) - (send red set-value (send color red)) + (send red set-value (send color red)) (send green set-value (send color green)) (send blue set-value (send color blue)) (send canvas refresh))]) diff --git a/collects/mred/private/mrcanvas.rkt b/collects/mred/private/mrcanvas.rkt index 627f831d..462e654c 100644 --- a/collects/mred/private/mrcanvas.rkt +++ b/collects/mred/private/mrcanvas.rkt @@ -19,9 +19,10 @@ (define canvas-default-size 20) ; a default size for canvases tht fits borders without losing client sizes (define canvas-scroll-size 10) -(define canvas-control-border-extra (case (system-type) - [(windows) 2] - [else 0])) +(define canvas-control-border-extra + (case (system-type) + [(windows) 2] + [else 0])) (define canvas<%> (interface (subwindow<%>) diff --git a/collects/mred/private/mred.rkt b/collects/mred/private/mred.rkt index 6e26e1b2..8f49d9fc 100644 --- a/collects/mred/private/mred.rkt +++ b/collects/mred/private/mred.rkt @@ -116,6 +116,7 @@ event-dispatch-handler eventspace? flush-display + get-current-mouse-state get-highlight-background-color get-highlight-text-color get-the-editor-data-class-list diff --git a/collects/mred/private/mritem.rkt b/collects/mred/private/mritem.rkt index 78108061..76cb3b57 100644 --- a/collects/mred/private/mritem.rkt +++ b/collects/mred/private/mritem.rkt @@ -600,7 +600,10 @@ [find-string (entry-point (lambda (x) (check-label-string '(method list-control<%> find-string) x) (do-find-string x)))] - + [delete (entry-point (lambda (n) + (check-item 'delete n) + (send this -delete-list-item n) + (send wx delete n)))] [-append-list-string (lambda (i) (set! content (append content (list i))))] [-set-list-string (lambda (i s) @@ -842,11 +845,7 @@ (set! num-columns (add1 num-columns)) (set! column-labels (append column-labels (list label))) (send wx append-column label))))] - - [delete (entry-point (lambda (n) - (check-item 'delete n) - (send this -delete-list-item n) - (send wx delete n)))] + [get-data (entry-point (lambda (n) (check-item 'get-data n) (send wx get-data n)))] [get-label-font (lambda () (send wx get-label-font))] [get-selections (entry-point (lambda () (send wx get-selections)))] diff --git a/collects/mred/private/mrmenu.rkt b/collects/mred/private/mrmenu.rkt index 4523958c..967c7cf7 100644 --- a/collects/mred/private/mrmenu.rkt +++ b/collects/mred/private/mrmenu.rkt @@ -465,6 +465,6 @@ (define (menu-or-bar-parent who p) (unless (or (is-a? p internal-menu<%>) (is-a? p menu-bar%)) (unless (is-a? p menu-item-container<%>) - (raise-arguments-error (constructor-name who) "(is-a?/c menu-item-container<%>)" p)) + (raise-argument-error (constructor-name who) "(is-a?/c menu-item-container<%>)" p)) (raise-arguments-error (who->name who) "invalid parent;\n given parent is not an instance of a built-in menu item container class" "given parent" p))) diff --git a/collects/mred/private/snipfile.rkt b/collects/mred/private/snipfile.rkt index 8f4c91ee..86113ee5 100644 --- a/collects/mred/private/snipfile.rkt +++ b/collects/mred/private/snipfile.rkt @@ -25,126 +25,134 @@ #:lock-while-reading? [lock-while-reading? #f]) ;; Check arguments: (unless (text . is-a? . text%) - (raise-argument-error 'open-input-text-editor "(is-a?/c text%)" text)) + (raise-argument-error 'open-input-text-editor "(is-a?/c text%)" text)) (check-non-negative-integer 'open-input-text-editor start) (unless (or (eq? end 'end) - (and (integer? end) (exact? end) (not (negative? end)))) - (raise-argument-error 'open-input-text-editor "(or/c exact-nonnegative-integer? 'end)" end)) + (and (integer? end) (exact? end) (not (negative? end)))) + (raise-argument-error 'open-input-text-editor "(or/c exact-nonnegative-integer? 'end)" end)) (let ([last (send text last-position)]) - (when (start . > . last) + (when (start . > . last) (raise-range-error 'open-input-text-editor "editor" "starting " start text 0 last #f)) - (unless (eq? end 'end) - (unless (<= start end last) + (unless (eq? end 'end) + (unless (<= start end last) (raise-range-error 'open-input-text-editor "editor" "ending " end text start last 0)))) (let ([end (if (eq? end 'end) (send text last-position) end)] - [snip (send text find-snip start 'after-or-none)]) - ;; If the region is small enough, and if the editor contains - ;; only string snips, then it's probably better to move - ;; all of the text into a string port: - (if (or (not snip) - (and (is-a? snip wx:string-snip%) - (let ([s (send text find-next-non-string-snip snip)]) - (or (not s) - ((send text get-snip-position s) . >= . end))))) - (if (or expect-to-read-all? - ((- end start) . < . 4096)) - ;; It's all text, and it's short enough: just read it into a string - (open-input-string (send text get-text start end) port-name) - ;; It's all text, so the reading process is simple: + [snip (send text find-snip start 'after-or-none)]) + ;; If the region is small enough, and if the editor contains + ;; only string snips, then it's probably better to move + ;; all of the text into a string port: + (if (or (not snip) + (and (is-a? snip wx:string-snip%) + (let ([s (send text find-next-non-string-snip snip)]) + (or (not s) + ((send text get-snip-position s) . >= . end))))) + (if (or expect-to-read-all? + ((- end start) . < . 4096)) + ;; It's all text, and it's short enough: just read it into a string + (open-input-string (send text get-text start end) port-name) + ;; It's all text, so the reading process is simple: (let ([start start]) (when lock-while-reading? (send text begin-edit-sequence) (send text lock #t)) (let-values ([(pipe-r pipe-w) (make-pipe)]) - (make-input-port/read-to-peek + (make-input-port/read-to-peek port-name - (lambda (s) - (let ([v (read-bytes-avail!* s pipe-r)]) - (if (eq? v 0) - (let ([n (min 4096 (- end start))]) - (if (zero? n) - (begin + (lambda (s) + (let ([v (read-bytes-avail!* s pipe-r)]) + (if (eq? v 0) + (let ([n (min 4096 (- end start))]) + (if (zero? n) + (begin (close-output-port pipe-w) - (when lock-while-reading? + (when lock-while-reading? (set! lock-while-reading? #f) (send text lock #f) (send text end-edit-sequence)) eof) - (begin - (write-string (send text get-text start (+ start n)) pipe-w) - (set! start (+ start n)) - (let ([ans (read-bytes-avail!* s pipe-r)]) + (begin + (write-string (send text get-text start (+ start n)) pipe-w) + (set! start (+ start n)) + (let ([ans (read-bytes-avail!* s pipe-r)]) (when lock-while-reading? (when (eof-object? ans) (set! lock-while-reading? #f) (send text lock #f) (send text edit-edit-sequence))) ans)))) - v))) + v))) (lambda (s skip general-peek) - (let ([v (peek-bytes-avail!* s skip #f pipe-r)]) - (if (eq? v 0) - (general-peek s skip) - v))) - void)))) - ;; General case, which handles non-text context: - (with-method ([gsp (text get-snip-position)] - [grn (text get-revision-number)]) - (let-values ([(pipe-r pipe-w) (make-pipe)]) - (let* ([get-text-generic (generic wx:snip% get-text)] - [get-count-generic (generic wx:snip% get-count)] - [next-generic (generic wx:snip% next)] - [revision (grn)] - [next? #f] - [update-str-to-snip - (lambda (to-str) - (if snip - (let ([snip-start (gsp snip)]) - (cond - [(snip-start . >= . end) - (set! snip #f) - (set! next? #f) - 0] - [(is-a? snip wx:string-snip%) - (set! next? #t) - (let ([c (min (send-generic snip get-count-generic) (- end snip-start))]) - (write-string (send-generic snip get-text-generic 0 c) pipe-w) - (read-bytes-avail!* to-str pipe-r))] - [else - (set! next? #f) - 0])) - (begin - (set! next? #f) - 0)))] - [next-snip - (lambda (to-str) - (unless (= revision (grn)) - (raise-arguments-error - 'text-input-port - "editor has changed since port was opened" - "editor" text)) - (set! snip (send-generic snip next-generic)) - (update-str-to-snip to-str))] - [read-chars (lambda (to-str) - (cond - [next? - (next-snip to-str)] - [snip - (let ([the-snip (snip-filter snip)]) - (next-snip empty-string) - (lambda (file line col ppos) - (if (is-a? the-snip wx:snip%) - (if (is-a? the-snip wx:readable-snip<%>) - (send the-snip read-special file line col ppos) - (send the-snip copy)) - the-snip)))] - [else eof]))] - [close (lambda () (void))] - [port (make-input-port/read-to-peek - port-name - (lambda (s) + (let ([v (peek-bytes-avail!* s skip #f pipe-r)]) + (if (eq? v 0) + (general-peek s skip) + v))) + void)))) + ;; General case, which handles non-text context: + (with-method ([gsp (text get-snip-position)] + [grn (text get-revision-number)] + [fs (text find-snip)]) + (let-values ([(pipe-r pipe-w) (make-pipe)]) + (let* ([get-text-generic (generic wx:snip% get-text)] + [get-count-generic (generic wx:snip% get-count)] + [next-generic (generic wx:snip% next)] + [revision (grn)] + [next? #f] + [snip-end-position (+ (gsp snip) (send-generic snip get-count-generic))] + [update-str-to-snip + (lambda (skip to-str) + (if snip + (let ([snip-start (gsp snip)]) + (cond + [(snip-start . >= . end) + (set! snip #f) + (set! next? #f) + 0] + [(is-a? snip wx:string-snip%) + (set! next? #t) + (let ([c (min (- (send-generic snip get-count-generic) skip) + (- end snip-start))]) + (write-string (send-generic snip get-text-generic skip c) pipe-w) + (read-bytes-avail!* to-str pipe-r))] + [else + (set! next? #f) + 0])) + (begin + (set! next? #f) + 0)))] + [next-snip + (lambda (to-str) + (cond + [(= revision (grn)) + (set! snip (send-generic snip next-generic)) + (set! snip-end-position (and snip (+ (gsp snip) (send-generic snip get-count-generic)))) + (update-str-to-snip 0 to-str)] + [else + (set! revision (grn)) + (define old-snip-end-position snip-end-position) + (set! snip (fs snip-end-position 'after-or-none)) + (define snip-start-position (and snip (gsp snip))) + (set! snip-end-position (and snip (+ snip-start-position (send-generic snip get-count-generic)))) + (update-str-to-snip (if snip (- old-snip-end-position snip-start-position) 0) to-str)]))] + [read-chars (lambda (to-str) + (cond + [next? + (next-snip to-str)] + [snip + (let ([the-snip (snip-filter snip)]) + (next-snip empty-string) + (lambda (file line col ppos) + (if (is-a? the-snip wx:snip%) + (if (is-a? the-snip wx:readable-snip<%>) + (send the-snip read-special file line col ppos) + (send the-snip copy)) + the-snip)))] + [else eof]))] + [close (lambda () (void))] + [port (make-input-port/read-to-peek + port-name + (lambda (s) (let* ([v (read-bytes-avail!* s pipe-r)] [res (if (eq? v 0) (read-chars s) v)]) (when (eof-object? res) @@ -154,25 +162,25 @@ (send text end-edit-sequence))) res)) (lambda (s skip general-peek) - (let ([v (peek-bytes-avail!* s skip #f pipe-r)]) - (if (eq? v 0) - (general-peek s skip) - v))) - close)]) - (when lock-while-reading? + (let ([v (peek-bytes-avail!* s skip #f pipe-r)]) + (if (eq? v 0) + (general-peek s skip) + v))) + close)]) + (when lock-while-reading? (send text begin-edit-sequence) (send text lock #t)) (if (is-a? snip wx:string-snip%) - ;; Special handling for initial snip string in - ;; case it starts too early: - (let* ([snip-start (gsp snip)] - [skip (- start snip-start)] - [c (min (- (send-generic snip get-count-generic) skip) - (- end snip-start))]) - (set! next? #t) - (display (send-generic snip get-text-generic skip c) pipe-w)) - (update-str-to-snip empty-string)) - port))))))) + ;; Special handling for initial snip string in + ;; case it starts too early: + (let* ([snip-start (gsp snip)] + [skip (- start snip-start)] + [c (min (- (send-generic snip get-count-generic) skip) + (- end snip-start))]) + (set! next? #t) + (display (send-generic snip get-text-generic skip c) pipe-w)) + (update-str-to-snip 0 empty-string)) + port))))))) (define (jump-to-submodule in-port expected-module k) (let ([header (bytes-append #"^#~" diff --git a/collects/mred/private/wx/cocoa/choice.rkt b/collects/mred/private/wx/cocoa/choice.rkt index c174789d..c15b724f 100644 --- a/collects/mred/private/wx/cocoa/choice.rkt +++ b/collects/mred/private/wx/cocoa/choice.rkt @@ -68,6 +68,8 @@ (tellv (get-cocoa) insertItemWithTitle: #:type _NSString lbl atIndex: #:type _NSInteger (number))) + (define/public (delete i) + (tellv (get-cocoa) removeItemAtIndex: #:type _NSInteger i)) (define/override (maybe-register-as-child parent on?) (register-as-child parent on?))) diff --git a/collects/mred/private/wx/cocoa/platform.rkt b/collects/mred/private/wx/cocoa/platform.rkt index 6ec950eb..1567a0c7 100644 --- a/collects/mred/private/wx/cocoa/platform.rkt +++ b/collects/mred/private/wx/cocoa/platform.rkt @@ -63,6 +63,7 @@ display-origin display-count flush-display + get-current-mouse-state fill-private-color cancel-quit get-control-font-face diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index 1d1400d1..63a656ec 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -6,6 +6,7 @@ ffi/unsafe ffi/unsafe/objc "utils.rkt" + "const.rkt" "types.rkt" "frame.rkt" "window.rkt" @@ -63,9 +64,10 @@ file-creator-and-type file-selector key-symbol-to-menu-key - needs-grow-box-spacer?) + needs-grow-box-spacer? + get-current-mouse-state) -(import-class NSScreen NSCursor NSMenu) +(import-class NSScreen NSCursor NSMenu NSEvent) (define (find-graphical-system-path what) #f) @@ -192,3 +194,28 @@ (define (needs-grow-box-spacer?) (not (version-10.7-or-later?))) + +;; ------------------------------------------------------------ +;; Mouse and modifier-key state + +(define (get-current-mouse-state) + (define posn (tell #:type _NSPoint NSEvent mouseLocation)) + (define buttons (tell #:type _NSUInteger NSEvent pressedMouseButtons)) + (define mods (tell #:type _NSUInteger NSEvent modifierFlags)) + (define (maybe v mask sym) + (if (zero? (bitwise-and v mask)) + null + (list sym))) + (define h (let ([f (tell #:type _NSRect (tell NSScreen mainScreen) frame)]) + (NSSize-height (NSRect-size f)))) + (values (make-object point% + (->long (NSPoint-x posn)) + (->long (- (- h (NSPoint-y posn)) (get-menu-bar-height)))) + (append + (maybe buttons #x1 'left) + (maybe buttons #x2 'right) + (maybe mods NSShiftKeyMask 'shift) + (maybe mods NSCommandKeyMask 'meta) + (maybe mods NSAlternateKeyMask 'alt) + (maybe mods NSControlKeyMask 'control) + (maybe mods NSAlphaShiftKeyMask 'caps)))) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index ed1b1dcd..ff0a22cd 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -604,6 +604,10 @@ (- y (client-y-offset)))))) (define/public (client-y-offset) 0) + (define event-position-wrt-wx #f) + (define/public (set-event-positions-wrt wx) + (set! event-position-wrt-wx wx)) + (define/public (is-view?) #t) (define/public (window-point-to-view pos) (let ([pos (if (is-view?) @@ -611,8 +615,17 @@ convertPoint: #:type _NSPoint pos fromView: #f) pos)]) - (values (NSPoint-x pos) - (flip-client (NSPoint-y pos))))) + (define x (NSPoint-x pos)) + (define y (flip-client (NSPoint-y pos))) + (cond + [event-position-wrt-wx + (define xb (box (->long x))) + (define yb (box (->long y))) + (internal-client-to-screen xb yb) + (send event-position-wrt-wx internal-screen-to-client xb yb) + (values (unbox xb) (unbox yb))] + [else (values x y)]))) + (define/public (get-x) (->long (NSPoint-x (NSRect-origin (get-frame))))) @@ -799,6 +812,8 @@ (define/public (refresh-all-children) (void)) (define/public (screen-to-client xb yb) + (internal-screen-to-client xb yb)) + (define/public (internal-screen-to-client xb yb) (let ([p (tell #:type _NSPoint (get-cocoa-content) convertPoint: #:type _NSPoint (tell #:type _NSPoint (get-cocoa-window) @@ -810,6 +825,8 @@ (set-box! yb (inexact->exact (floor (flip-client (NSPoint-y p))))))) (define/public (client-to-screen xb yb [flip-y? #t]) + (internal-client-to-screen xb yb flip-y?)) + (define/public (internal-client-to-screen xb yb [flip-y? #t]) (let* ([p (tell #:type _NSPoint (get-cocoa-window) convertBaseToScreen: #:type _NSPoint diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index fab54e0f..35ba24af 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -438,12 +438,23 @@ (define event-dispatch-handler (make-parameter really-dispatch-event)) +(define event-logger (make-logger 'gui-event (current-logger))) +;; start? : boolean -- indicates if this is a start of an event being handled or not +;; msec : start time if start? is #t, delta from start to end if start? is #f +;; name : (or/c #f symbol?) +(struct gui-event (start end name) #:prefab) + (define (handle-event thunk e) (call-with-continuation-prompt ; to delimit continuations (lambda () (call-with-continuation-prompt ; to delimit search for dispatch-event-key (lambda () ;; communicate the thunk to `really-dispatch-event': + (define before (current-inexact-milliseconds)) + (when (log-level? event-logger 'debug) + (log-message event-logger 'debug + "starting to handle an event" + (gui-event before #f (object-name thunk)))) (let ([b (box thunk)]) ;; use the event-dispatch handler: (with-continuation-mark dispatch-event-key b @@ -452,7 +463,13 @@ ;; to the original one, then do so now: (when (unbox b) (set-box! b #f) - (thunk)))) + (thunk))) + (define after (current-inexact-milliseconds)) + (when (log-level? event-logger 'debug) + (log-message event-logger 'debug + (format "handled an event: ~a msec" + (- after before)) + (gui-event before after (object-name thunk))))) dispatch-event-prompt)))) (define yield diff --git a/collects/mred/private/wx/gtk/choice.rkt b/collects/mred/private/wx/gtk/choice.rkt index 39802d2c..b5c9d9ef 100644 --- a/collects/mred/private/wx/gtk/choice.rkt +++ b/collects/mred/private/wx/gtk/choice.rkt @@ -78,9 +78,12 @@ (set! ignore-clicked? #t) (gtk_combo_box_set_active gtk i) (set! ignore-clicked? #f))) + (define/public (get-selection) (gtk_combo_box_get_active gtk)) + (define/public (number) count) + (define/public (clear) (atomically (set! ignore-clicked? #t) @@ -88,6 +91,7 @@ (gtk_combo_box_remove_text gtk 0)) (set! count 0) (set! ignore-clicked? #f))) + (public [-append append]) (define (-append l) (atomically @@ -96,5 +100,7 @@ (gtk_combo_box_append_text gtk l) (when (= count 1) (set-selection 0)) - (set! ignore-clicked? #f)))) + (set! ignore-clicked? #f))) + (define/public (delete i) + (gtk_combo_box_remove_text gtk i))) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index e9fc5a56..59fa9963 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -22,7 +22,8 @@ display-origin display-size display-count - location->window)) + location->window + get-current-mouse-state)) ;; ---------------------------------------- @@ -57,6 +58,13 @@ (define-gtk gtk_window_resize (_fun _GtkWidget _int _int -> _void)) (define-gdk gdk_window_set_cursor (_fun _GdkWindow _pointer -> _void)) +(define-gdk gdk_screen_get_root_window (_fun _GdkScreen -> _GdkWindow)) +(define-gdk gdk_window_get_pointer (_fun _GdkWindow + (x : (_ptr o _int)) + (y : (_ptr o _int)) + (mods : (_ptr o _uint)) + -> _GdkWindow + -> (values x y mods))) (define-gtk gtk_window_iconify (_fun _GtkWindow -> _void)) (define-gtk gtk_window_deiconify (_fun _GtkWindow -> _void)) @@ -169,7 +177,7 @@ (values vbox-gtk panel-gtk)))) (gtk_widget_show vbox-gtk) (gtk_widget_show panel-gtk) - (connect-key-and-mouse gtk) + (connect-enter-and-leave gtk) (unless is-dialog? (gtk_window_set_icon_list gtk (cdr (force icon-pixbufs+glist)))) @@ -424,7 +432,7 @@ (define/override (call-pre-on-char w e) (pre-on-char w e)) - (define/override (client-to-screen x y) + (define/override (internal-client-to-screen x y) (gtk_window_set_gravity gtk GDK_GRAVITY_STATIC) (let-values ([(dx dy) (gtk_window_get_position gtk)] [(cdx cdy) (get-client-delta)]) @@ -543,3 +551,24 @@ [fh (send f get-height)]) (<= fy y (+ fy fh))) f)))) + +;; ---------------------------------------- + +(define (get-current-mouse-state) + (define-values (x y mods) (gdk_window_get_pointer + (gdk_screen_get_root_window + (gdk_screen_get_default)))) + (define (maybe mask sym) + (if (zero? (bitwise-and mods mask)) + null + (list sym))) + (values (make-object point% x y) + (append + (maybe GDK_BUTTON1_MASK 'left) + (maybe GDK_BUTTON2_MASK 'middle) + (maybe GDK_BUTTON3_MASK 'right) + (maybe GDK_SHIFT_MASK 'shift) + (maybe GDK_LOCK_MASK 'caps) + (maybe GDK_CONTROL_MASK 'control) + (maybe GDK_MOD1_MASK 'alt) + (maybe GDK_META_MASK 'meta)))) diff --git a/collects/mred/private/wx/gtk/platform.rkt b/collects/mred/private/wx/gtk/platform.rkt index a54adf28..1194feef 100644 --- a/collects/mred/private/wx/gtk/platform.rkt +++ b/collects/mred/private/wx/gtk/platform.rkt @@ -64,6 +64,7 @@ display-origin display-count flush-display + get-current-mouse-state fill-private-color cancel-quit get-control-font-face diff --git a/collects/mred/private/wx/gtk/types.rkt b/collects/mred/private/wx/gtk/types.rkt index 59aea507..15841e07 100644 --- a/collects/mred/private/wx/gtk/types.rkt +++ b/collects/mred/private/wx/gtk/types.rkt @@ -8,8 +8,8 @@ _GdkScreen _gpointer _GType - _GdkEventType - _GdkAtom + _GdkEventType + _GdkAtom _fnpointer _gboolean @@ -31,9 +31,9 @@ (struct-out GdkEventExpose) _GdkEventFocus _GdkEventFocus-pointer (struct-out GdkEventFocus) - _GdkEventSelection _GdkEventSelection-pointer + _GdkEventSelection _GdkEventSelection-pointer (struct-out GdkEventSelection) - _GdkRectangle _GdkRectangle-pointer + _GdkRectangle _GdkRectangle-pointer (struct-out GdkRectangle) _GdkColor _GdkColor-pointer (struct-out GdkColor))) @@ -135,11 +135,11 @@ (define-cstruct _GdkEventSelection ([type _GdkEventType] [window _GdkWindow] [send_event _byte] - [selection _GdkAtom] - [target _GdkAtom] - [property _GdkAtom] - [time _uint32] - [requestor _pointer])) + [selection _GdkAtom] + [target _GdkAtom] + [property _GdkAtom] + [time _uint32] + [requestor _pointer])) (define-cstruct _GdkRectangle ([x _int] [y _int] @@ -155,8 +155,8 @@ (define-cstruct _GdkEventFocus ([type _GdkEventType] [window _GdkWindow] - [send_event _byte] - [in _short])) + [send_event _byte] + [in _short])) (define-cstruct _GdkColor ([pixel _uint32] [red _uint16] diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 87c0d0e6..8ee99033 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -1,7 +1,7 @@ #lang racket/base (require ffi/unsafe racket/class - net/uri-codec + net/uri-codec ffi/unsafe/atomic "../../syntax.rkt" "../../lock.rkt" @@ -18,7 +18,7 @@ "const.rkt" "types.rkt" "widget.rkt" - "clipboard.rkt") + "clipboard.rkt") (provide (protect-out window% @@ -35,6 +35,7 @@ connect-focus connect-key-and-mouse + connect-enter-and-leave do-button-event (struct-out GtkRequisition) _GtkRequisition-pointer @@ -53,9 +54,9 @@ request-flush-delay cancel-flush-delay - win-box-valid? - window->win-box - unrealize-win-box) + win-box-valid? + window->win-box + unrealize-win-box) gtk->wx gtk_widget_show gtk_widget_hide) @@ -91,15 +92,15 @@ (define the-accelerator-group (gtk_accel_group_new)) (define-cstruct _GtkWidgetT ([obj _GtkObject] - [private_flags _uint16] - [state _byte] - [saved_state _byte] - [name _pointer] - [style _pointer] - [req _GtkRequisition] - [alloc _GtkAllocation] - [window _GdkWindow] - [parent _GtkWidget])) + [private_flags _uint16] + [state _byte] + [saved_state _byte] + [name _pointer] + [style _pointer] + [req _GtkRequisition] + [alloc _GtkAllocation] + [window _GdkWindow] + [parent _GtkWidget])) (define (widget-window gtk) (GtkWidgetT-window (cast gtk _GtkWidget _GtkWidgetT-pointer))) @@ -122,20 +123,20 @@ (lambda (gtk context x y data info time) (let ([wx (gtk->wx gtk)]) (when wx - (let ([bstr (scheme_make_sized_byte_string - (gtk_selection_data_get_data data) - (gtk_selection_data_get_length data) - 1)]) - (cond - [(regexp-match #rx#"^file://(.*)\r\n$" bstr) - => (lambda (m) - (queue-window-event wx - (lambda () - (let ([path - (string->path - (uri-decode - (bytes->string/utf-8 (cadr m))))]) - (send wx on-drop-file path)))))])))))) + (let ([bstr (scheme_make_sized_byte_string + (gtk_selection_data_get_data data) + (gtk_selection_data_get_length data) + 1)]) + (cond + [(regexp-match #rx#"^file://(.*)\r\n$" bstr) + => (lambda (m) + (queue-window-event wx + (lambda () + (let ([path + (string->path + (uri-decode + (bytes->string/utf-8 (cadr m))))]) + (send wx on-drop-file path)))))])))))) ;; ---------------------------------------- @@ -146,7 +147,7 @@ (when wx (send wx focus-change #t) (when (send wx on-focus? #t) - (queue-window-event wx (lambda () (send wx on-set-focus))))) + (queue-window-event wx (lambda () (send wx on-set-focus))))) #f))) (define-signal-handler connect-focus-out "focus-out-event" (_fun _GtkWidget _GdkEventFocus-pointer -> _gboolean) @@ -194,72 +195,72 @@ (and wx (let ([im-str (if scroll? - 'none - ;; Result from `filter-key-event' is one of - ;; - #f => drop the event - ;; - 'none => no replacement; handle as usual - ;; - a string => use as the keycode - (send wx filter-key-event event))]) + 'none + ;; Result from `filter-key-event' is one of + ;; - #f => drop the event + ;; - 'none => no replacement; handle as usual + ;; - a string => use as the keycode + (send wx filter-key-event event))]) (when im-str - (let* ([modifiers (if scroll? - (GdkEventScroll-state event) - (GdkEventKey-state event))] - [bit? (lambda (m v) (positive? (bitwise-and m v)))] - [keyval->code (lambda (kv) - (or - (map-key-code kv) - (integer->char (gdk_keyval_to_unicode kv))))] - [key-code (if scroll? - (let ([dir (GdkEventScroll-direction event)]) + (let* ([modifiers (if scroll? + (GdkEventScroll-state event) + (GdkEventKey-state event))] + [bit? (lambda (m v) (positive? (bitwise-and m v)))] + [keyval->code (lambda (kv) + (or + (map-key-code kv) + (integer->char (gdk_keyval_to_unicode kv))))] + [key-code (if scroll? + (let ([dir (GdkEventScroll-direction event)]) (cond [(= dir GDK_SCROLL_UP) 'wheel-up] [(= dir GDK_SCROLL_DOWN) 'wheel-down] [(= dir GDK_SCROLL_LEFT) 'wheel-left] [(= dir GDK_SCROLL_RIGHT) 'wheel-right])) - (keyval->code (GdkEventKey-keyval event)))] - [k (new key-event% - [key-code (if (and (string? im-str) - (= 1 (string-length im-str))) - (string-ref im-str 0) - key-code)] - [shift-down (bit? modifiers GDK_SHIFT_MASK)] - [control-down (bit? modifiers GDK_CONTROL_MASK)] - [meta-down (bit? modifiers GDK_MOD1_MASK)] - [alt-down (bit? modifiers GDK_META_MASK)] - [x 0] - [y 0] - [time-stamp (if scroll? - (GdkEventScroll-time event) - (GdkEventKey-time event))] - [caps-down (bit? modifiers GDK_LOCK_MASK)])]) - (when (or (and (not scroll?) - (let-values ([(s ag sag cl) (get-alts event)] - [(keyval->code*) (lambda (v) - (and v - (let ([c (keyval->code v)]) - (and (not (equal? #\u0000 c)) - c))))]) - (let ([s (keyval->code* s)] - [ag (keyval->code* ag)] - [sag (keyval->code* sag)] - [cl (keyval->code* cl)]) - (when s (send k set-other-shift-key-code s)) - (when ag (send k set-other-altgr-key-code ag)) - (when sag (send k set-other-shift-altgr-key-code sag)) - (when cl (send k set-other-caps-key-code cl)) - (or s ag sag cl)))) - (not (equal? #\u0000 key-code))) - (unless (or scroll? down?) - ;; swap altenate with main - (send k set-key-release-code (send k get-key-code)) - (send k set-key-code 'release)) - (if (send wx handles-events? gtk) - (begin - (queue-window-event wx (lambda () (send wx dispatch-on-char k #f))) - #t) - (constrained-reply (send wx get-eventspace) - (lambda () (send wx dispatch-on-char k #t)) - #t))))))))) + (keyval->code (GdkEventKey-keyval event)))] + [k (new key-event% + [key-code (if (and (string? im-str) + (= 1 (string-length im-str))) + (string-ref im-str 0) + key-code)] + [shift-down (bit? modifiers GDK_SHIFT_MASK)] + [control-down (bit? modifiers GDK_CONTROL_MASK)] + [meta-down (bit? modifiers GDK_MOD1_MASK)] + [alt-down (bit? modifiers GDK_META_MASK)] + [x 0] + [y 0] + [time-stamp (if scroll? + (GdkEventScroll-time event) + (GdkEventKey-time event))] + [caps-down (bit? modifiers GDK_LOCK_MASK)])]) + (when (or (and (not scroll?) + (let-values ([(s ag sag cl) (get-alts event)] + [(keyval->code*) (lambda (v) + (and v + (let ([c (keyval->code v)]) + (and (not (equal? #\u0000 c)) + c))))]) + (let ([s (keyval->code* s)] + [ag (keyval->code* ag)] + [sag (keyval->code* sag)] + [cl (keyval->code* cl)]) + (when s (send k set-other-shift-key-code s)) + (when ag (send k set-other-altgr-key-code ag)) + (when sag (send k set-other-shift-altgr-key-code sag)) + (when cl (send k set-other-caps-key-code cl)) + (or s ag sag cl)))) + (not (equal? #\u0000 key-code))) + (unless (or scroll? down?) + ;; swap altenate with main + (send k set-key-release-code (send k get-key-code)) + (send k set-key-code 'release)) + (if (send wx handles-events? gtk) + (begin + (queue-window-event wx (lambda () (send wx dispatch-on-char k #f))) + #t) + (constrained-reply (send wx get-eventspace) + (lambda () (send wx dispatch-on-char k #t)) + #t))))))))) (define-signal-handler connect-button-press "button-press-event" (_fun _GtkWidget _GdkEventButton-pointer -> _gboolean) @@ -293,6 +294,10 @@ (let ([wx (gtk->wx gtk)]) (when wx (send wx leave-window))) (do-button-event gtk event #f #t))) +(define (connect-enter-and-leave gtk) + (connect-enter gtk) + (connect-leave gtk)) + (define (connect-key-and-mouse gtk [skip-press? #f]) (connect-key-press gtk) (connect-key-release gtk) @@ -300,8 +305,7 @@ (connect-button-press gtk) (unless skip-press? (connect-button-release gtk)) (connect-pointer-motion gtk) - (connect-enter gtk) - (connect-leave gtk)) + (connect-enter-and-leave gtk)) (define (do-button-event gtk event motion? crossing?) (let ([type (if motion? @@ -313,11 +317,11 @@ (and wx (if (or (= type GDK_2BUTTON_PRESS) - (= type GDK_3BUTTON_PRESS) - (and (or (= type GDK_ENTER_NOTIFY) - (= type GDK_LEAVE_NOTIFY)) - (send wx skip-enter-leave-events))) - #t + (= type GDK_3BUTTON_PRESS) + (and (or (= type GDK_ENTER_NOTIFY) + (= type GDK_LEAVE_NOTIFY)) + (send wx skip-enter-leave-events))) + #t (let* ([modifiers (if motion? (GdkEventMotion-state event) (if crossing? @@ -341,53 +345,57 @@ [(1) 'left-up] [(3) 'right-up] [else 'middle-up])])] - [m (new mouse-event% - [event-type type] - [left-down (case type - [(left-down) #t] - [(left-up) #f] - [else (bit? modifiers GDK_BUTTON1_MASK)])] - [middle-down (case type - [(middle-down) #t] - [(middle-up) #f] - [else (bit? modifiers GDK_BUTTON2_MASK)])] - [right-down (case type - [(right-down) #t] - [(right-up) #f] - [else (bit? modifiers GDK_BUTTON3_MASK)])] - [x (->long ((if motion? - GdkEventMotion-x - (if crossing? GdkEventCrossing-x GdkEventButton-x)) - event))] - [y (->long ((if motion? GdkEventMotion-y - (if crossing? GdkEventCrossing-y GdkEventButton-y)) - event))] - [shift-down (bit? modifiers GDK_SHIFT_MASK)] - [control-down (bit? modifiers GDK_CONTROL_MASK)] - [meta-down (bit? modifiers GDK_META_MASK)] - [alt-down (bit? modifiers GDK_MOD1_MASK)] - [time-stamp ((if motion? GdkEventMotion-time - (if crossing? GdkEventCrossing-time GdkEventButton-time)) - event)] - [caps-down (bit? modifiers GDK_LOCK_MASK)])]) - (if (send wx handles-events? gtk) - (begin - (queue-window-event wx (lambda () - (send wx dispatch-on-event m #f))) - #t) - (constrained-reply (send wx get-eventspace) - (lambda () (or (send wx dispatch-on-event m #t) - (send wx internal-pre-on-event gtk m))) - #t - #:fail-result - ;; an enter event is synthesized when a button is - ;; enabled and the mouse is over the button, and the - ;; event is not dispatched via the eventspace; leave - ;; events are perhaps similarly synthesized, so allow - ;; them, too - (if (or (eq? type 'enter) (eq? type 'leave)) - #f - #t))))))))) + [m (let-values ([(x y) (send wx + adjust-event-position + (->long ((if motion? + GdkEventMotion-x + (if crossing? GdkEventCrossing-x GdkEventButton-x)) + event)) + (->long ((if motion? GdkEventMotion-y + (if crossing? GdkEventCrossing-y GdkEventButton-y)) + event)))]) + (new mouse-event% + [event-type type] + [left-down (case type + [(left-down) #t] + [(left-up) #f] + [else (bit? modifiers GDK_BUTTON1_MASK)])] + [middle-down (case type + [(middle-down) #t] + [(middle-up) #f] + [else (bit? modifiers GDK_BUTTON2_MASK)])] + [right-down (case type + [(right-down) #t] + [(right-up) #f] + [else (bit? modifiers GDK_BUTTON3_MASK)])] + [x x] + [y y] + [shift-down (bit? modifiers GDK_SHIFT_MASK)] + [control-down (bit? modifiers GDK_CONTROL_MASK)] + [meta-down (bit? modifiers GDK_META_MASK)] + [alt-down (bit? modifiers GDK_MOD1_MASK)] + [time-stamp ((if motion? GdkEventMotion-time + (if crossing? GdkEventCrossing-time GdkEventButton-time)) + event)] + [caps-down (bit? modifiers GDK_LOCK_MASK)]))]) + (if (send wx handles-events? gtk) + (begin + (queue-window-event wx (lambda () + (send wx dispatch-on-event m #f))) + #t) + (constrained-reply (send wx get-eventspace) + (lambda () (or (send wx dispatch-on-event m #t) + (send wx internal-pre-on-event gtk m))) + #t + #:fail-result + ;; an enter event is synthesized when a button is + ;; enabled and the mouse is over the button, and the + ;; event is not dispatched via the eventspace; leave + ;; events are perhaps similarly synthesized, so allow + ;; them, too + (if (or (eq? type 'enter) (eq? type 'leave)) + #f + #t))))))))) ;; ---------------------------------------- @@ -584,13 +592,13 @@ (define drag-connected? #f) (define/public (drag-accept-files on?) (if on? - (begin - (unless drag-connected? - (connect-drag-data-received gtk) - (set! drag-connected? #t)) - (gtk_drag_dest_set gtk GTK_DEST_DEFAULT_ALL GDK_ACTION_COPY) - (gtk_drag_dest_add_uri_targets gtk)) - (gtk_drag_dest_unset gtk))) + (begin + (unless drag-connected? + (connect-drag-data-received gtk) + (set! drag-connected? #t)) + (gtk_drag_dest_set gtk GTK_DEST_DEFAULT_ALL GDK_ACTION_COPY) + (gtk_drag_dest_add_uri_targets gtk)) + (gtk_drag_dest_unset gtk))) (define/public (set-focus) (gtk_widget_grab_focus (get-client-gtk))) @@ -693,17 +701,34 @@ (define/public (refresh-all-children) (void)) (define/public (screen-to-client x y) + (internal-screen-to-client x y)) + (define/public (internal-screen-to-client x y) (let ([xb (box 0)] [yb (box 0)]) - (client-to-screen xb yb) + (internal-client-to-screen xb yb) (set-box! x (- (unbox x) (unbox xb))) (set-box! y (- (unbox y) (unbox yb))))) (define/public (client-to-screen x y) + (internal-client-to-screen x y)) + (define/public (internal-client-to-screen x y) (let-values ([(dx dy) (get-client-delta)]) - (send parent client-to-screen x y) + (send parent internal-client-to-screen x y) (set-box! x (+ (unbox x) save-x dx)) (set-box! y (+ (unbox y) save-y dy)))) + (define event-position-wrt-wx #f) + (define/public (set-event-positions-wrt wx) + (set! event-position-wrt-wx wx)) + + (define/public (adjust-event-position x y) + (if event-position-wrt-wx + (let ([xb (box x)] + [yb (box y)]) + (internal-client-to-screen xb yb) + (send event-position-wrt-wx internal-screen-to-client xb yb) + (values (unbox xb) (unbox yb))) + (values x y))) + (define/public (get-client-delta) (values 0 0)) @@ -736,7 +761,7 @@ (when win (set-mcar! win-box #f) (for ([i (in-range (mcdr win-box))]) - (gdk_window_thaw_updates win))))) + (gdk_window_thaw_updates win))))) (define (request-flush-delay win-box) (do-request-flush-delay @@ -744,15 +769,15 @@ (lambda (win-box) (let ([win (mcar win-box)]) (and win - ;; The freeze/thaw state is actually with the window's - ;; implementation, so force a native implementation of the - ;; window to try to avoid it changing out from underneath - ;; us between the freeze and thaw actions. - (gdk_window_ensure_native win) - (begin - (gdk_window_freeze_updates win) - (set-mcdr! win-box (add1 (mcdr win-box))) - #t)))) + ;; The freeze/thaw state is actually with the window's + ;; implementation, so force a native implementation of the + ;; window to try to avoid it changing out from underneath + ;; us between the freeze and thaw actions. + (gdk_window_ensure_native win) + (begin + (gdk_window_freeze_updates win) + (set-mcdr! win-box (add1 (mcdr win-box))) + #t)))) (lambda (win-box) (let ([win (mcar win-box)]) (when win @@ -766,5 +791,5 @@ (lambda (win-box) (let ([win (mcar win-box)]) (when win - (gdk_window_thaw_updates win) + (gdk_window_thaw_updates win) (set-mcdr! win-box (sub1 (mcdr win-box))))))))) diff --git a/collects/mred/private/wx/platform.rkt b/collects/mred/private/wx/platform.rkt index 352f6366..5c2e0654 100644 --- a/collects/mred/private/wx/platform.rkt +++ b/collects/mred/private/wx/platform.rkt @@ -50,6 +50,7 @@ display-origin display-count flush-display + get-current-mouse-state fill-private-color cancel-quit get-control-font-face diff --git a/collects/mred/private/wx/win32/choice.rkt b/collects/mred/private/wx/win32/choice.rkt index 74a4c9d2..b14ecb91 100644 --- a/collects/mred/private/wx/win32/choice.rkt +++ b/collects/mred/private/wx/win32/choice.rkt @@ -102,13 +102,13 @@ (SendMessageW hwnd CB_RESETCONTENT 0 0) (set! num-choices 0))) - (public [append* append]) (define (append* str) (atomically (SendMessageW/str hwnd CB_ADDSTRING 0 str) (set! num-choices (add1 num-choices)) - (when (= 1 num-choices) (set-selection 0)))))) - - + (when (= 1 num-choices) (set-selection 0)))) + (define/public (delete i) + (set! num-choices (sub1 num-choices)) + (void (SendMessageW hwnd CB_DELETESTRING i 0))))) diff --git a/collects/mred/private/wx/win32/const.rkt b/collects/mred/private/wx/win32/const.rkt index 7b96f9f6..0ace67bf 100644 --- a/collects/mred/private/wx/win32/const.rkt +++ b/collects/mred/private/wx/win32/const.rkt @@ -617,6 +617,7 @@ (define CB_SETCURSEL #x014E) (define CB_GETCURSEL #x0147) (define CB_ADDSTRING #x0143) +(define CB_DELETESTRING #x0144) (define CB_RESETCONTENT #x014B) (define CBN_SELENDOK 9) diff --git a/collects/mred/private/wx/win32/platform.rkt b/collects/mred/private/wx/win32/platform.rkt index 0a70c3d3..e3d775ef 100644 --- a/collects/mred/private/wx/win32/platform.rkt +++ b/collects/mred/private/wx/win32/platform.rkt @@ -64,6 +64,7 @@ display-origin display-count flush-display + get-current-mouse-state fill-private-color cancel-quit get-control-font-face diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 7c7f6d87..81ef379e 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -43,6 +43,7 @@ get-highlight-text-color check-for-break) flush-display + get-current-mouse-state fill-private-color play-sound location->window @@ -116,3 +117,26 @@ (define (check-for-break) #f) (define (needs-grow-box-spacer?) #f) + +(define-user32 GetCursorPos (_wfun (p : (_ptr o _POINT)) -> (r : _BOOL) + -> (if r + p + (failed 'GetCursorPos)))) +(define-user32 GetAsyncKeyState (_wfun _int -> _SHORT)) +(define-user32 GetSystemMetrics (_wfun _int -> _int)) +(define SM_SWAPBUTTON 23) +(define (get-current-mouse-state) + (define p (GetCursorPos)) + (define (maybe vk sym) + (if (negative? (GetAsyncKeyState vk)) + (list sym) + null)) + (define swapped? (not (zero? (GetSystemMetrics SM_SWAPBUTTON)))) + (values (make-object point% (POINT-x p) (POINT-y p)) + (append + (maybe (if swapped? VK_RBUTTON VK_LBUTTON) 'left) + (maybe (if swapped? VK_LBUTTON VK_RBUTTON) 'right) + (maybe VK_LSHIFT 'shift) + (maybe VK_CONTROL 'control) + (maybe VK_MENU 'alt) + (maybe VK_CAPITAL 'caps)))) diff --git a/collects/mred/private/wx/win32/types.rkt b/collects/mred/private/wx/win32/types.rkt index d446fedc..6fbfee97 100644 --- a/collects/mred/private/wx/win32/types.rkt +++ b/collects/mred/private/wx/win32/types.rkt @@ -1,13 +1,13 @@ #lang racket/base (require ffi/unsafe - ffi/winapi) + ffi/winapi) (provide (protect-out _wfun - _WORD - _DWORD - _UDWORD + _WORD + _DWORD + _UDWORD _ATOM _WPARAM _LPARAM @@ -95,35 +95,35 @@ (define _permanent-string/utf-16 (make-ctype _pointer - (lambda (s) - (and s - (let ([v (malloc _gcpointer)]) - (ptr-set! v _string/utf-16 s) - (let ([p (ptr-ref v _gcpointer)]) - (let ([len (+ 1 (utf-16-length s))]) - (let ([c (malloc len _uint16 'raw)]) - (memcpy c p len _uint16) - c)))))) - (lambda (p) p))) + (lambda (s) + (and s + (let ([v (malloc _gcpointer)]) + (ptr-set! v _string/utf-16 s) + (let ([p (ptr-ref v _gcpointer)]) + (let ([len (+ 1 (utf-16-length s))]) + (let ([c (malloc len _uint16 'raw)]) + (memcpy c p len _uint16) + c)))))) + (lambda (p) p))) (define _LONG _long) (define _ULONG _ulong) (define _SHORT _short) (define-cstruct _POINT ([x _LONG] - [y _LONG])) + [y _LONG])) (define-cstruct _RECT ([left _LONG] - [top _LONG] - [right _LONG] - [bottom _LONG])) + [top _LONG] + [right _LONG] + [bottom _LONG])) (define-cstruct _MSG ([hwnd _HWND] - [message _UINT] - [wParam _WPARAM] - [lParam _LPARAM] - [time _DWORD] - [pt _POINT])) + [message _UINT] + [wParam _WPARAM] + [lParam _LPARAM] + [time _DWORD] + [pt _POINT])) (define (short v) (if (zero? (bitwise-and #x8000 v)) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 23d0f506..6e3979a5 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -412,12 +412,29 @@ (define/public (on-resized) (void)) + (define event-position-wrt-wx #f) + (define/public (set-event-positions-wrt wx) + (set! event-position-wrt-wx wx)) + + (define/private (adjust-event-position x y) + (if event-position-wrt-wx + (let ([xb (box x)] + [yb (box y)]) + (internal-client-to-screen xb yb) + (send event-position-wrt-wx internal-screen-to-client xb yb) + (values (unbox xb) (unbox yb))) + (values x y))) + (define/public (screen-to-client x y) + (internal-screen-to-client x y)) + (define/public (internal-screen-to-client x y) (let ([p (make-POINT (unbox x) (unbox y))]) (ScreenToClient (get-client-hwnd) p) (set-box! x (POINT-x p)) (set-box! y (POINT-y p)))) (define/public (client-to-screen x y) + (internal-client-to-screen x y)) + (define/public (internal-client-to-screen x y) (let ([p (make-POINT (unbox x) (unbox y))]) (ClientToScreen (get-client-hwnd) p) (set-box! x (POINT-x p)) @@ -607,6 +624,7 @@ [bit? (lambda (v b) (not (zero? (bitwise-and v b))))]) (let ([make-e (lambda (type) + (define-values (mx my) (adjust-event-position x y)) (new mouse-event% [event-type type] [left-down (case type @@ -621,8 +639,8 @@ [(right-down) #t] [(right-up) #f] [else (bit? flags MK_RBUTTON)])] - [x x] - [y y] + [x mx] + [y my] [shift-down (bit? flags MK_SHIFT)] [control-down (bit? flags MK_CONTROL)] [meta-down #f] diff --git a/collects/mred/private/wxlitem.rkt b/collects/mred/private/wxlitem.rkt index fa55722d..a32d650c 100644 --- a/collects/mred/private/wxlitem.rkt +++ b/collects/mred/private/wxlitem.rkt @@ -59,7 +59,7 @@ (define wx-label-panel% (class wx-control-horizontal-panel% (init proxy parent label style font halign valign) - (inherit area-parent skip-enter-leave-events) + (inherit area-parent skip-enter-leave-events set-event-positions-wrt) (define c #f) (define/override (enable on?) (if c (send c enable on?) (void))) @@ -77,9 +77,21 @@ (define/public (set-label s) (when l (send l set-label s))) (define/public (get-label) (and l (send l get-label))) + (define/override (client-to-screen x y) + (if c + (send c client-to-screen x y) + (super client-to-screen x y))) + (define/override (screen-to-client x y) + (if c + (send c screen-to-client x y) + (super screen-to-client x y))) + (define/public (get-p) p) (define/public (set-c v sx? sy?) (set! c v) + (set-event-positions-wrt c) + (when l (send l set-event-positions-wrt c)) + (when p (send p set-event-positions-wrt c)) (send c stretchable-in-x sx?) (send c stretchable-in-y sy?) (send c skip-subwindow-events? #t)))) @@ -113,7 +125,8 @@ (get-selection) (number) (clear) - (append lbl)) + (append lbl) + (delete i)) (stretchable-in-y #f) (stretchable-in-x #f))) diff --git a/collects/mred/private/wxpanel.rkt b/collects/mred/private/wxpanel.rkt index c7e279cf..471fe6c9 100644 --- a/collects/mred/private/wxpanel.rkt +++ b/collects/mred/private/wxpanel.rkt @@ -54,6 +54,7 @@ (unless (negative? h) (set! height h)))] [get-x (lambda () pos-x)] [get-y (lambda () pos-y)] + [set-event-positions-wrt (lambda (c) (void))] [get-width (lambda () width)] [get-height (lambda () height)] [adopt-child (lambda (c) (send (get-parent) adopt-child c))]) diff --git a/collects/mrlib/graph.rkt b/collects/mrlib/graph.rkt index a87e68f0..b466956d 100644 --- a/collects/mrlib/graph.rkt +++ b/collects/mrlib/graph.rkt @@ -3,7 +3,8 @@ racket/list racket/math racket/gui/base - (for-syntax racket/base) + racket/match + (for-syntax racket/base) racket/contract) (provide graph-snip<%> @@ -377,7 +378,7 @@ (let ([old-currently-overs currently-overs]) (set! currently-overs new-currently-overs) - (on-mouse-over-snips currently-overs) + (on-mouse-over-snips currently-overs) (for-each (lambda (old-currently-over) (invalidate-to-children/parents old-currently-over dc)) @@ -386,9 +387,8 @@ (lambda (new-currently-over) (invalidate-to-children/parents new-currently-over dc)) new-currently-overs)))) - - (define/public (on-mouse-over-snips snips) - (void)) + + (define/public (on-mouse-over-snips snips) (void)) ;; set-equal : (listof snip) (listof snip) -> boolean ;; typically lists will be small (length 1), @@ -401,57 +401,42 @@ ;; invalidate-to-children/parents : snip dc -> void ;; invalidates the region containing this snip and ;; all of its children and parents. - (inherit invalidate-bitmap-cache) (define/private (invalidate-to-children/parents snip dc) (when (is-a? snip graph-snip<%>) - (let* ([parents-and-children (append (get-all-parents snip) - (get-all-children snip))] - [rects (eliminate-redundancies (get-rectangles snip parents-and-children))] - [or/c (or/c-rects rects)] - [text-height (call-with-values - (λ () (send dc get-text-extent "Label" #f #f 0)) - (λ (w h a s) h))] - [invalidate-rect - (lambda (rect) - (invalidate-bitmap-cache (- (rect-left rect) text-height) - (- (rect-top rect) text-height) - (+ (- (rect-right rect) - (rect-left rect)) - text-height) - (+ (- (rect-bottom rect) - (rect-top rect)) - text-height)))]) - (cond - [(< (rect-area or/c) - (apply + (map (lambda (x) (rect-area x)) rects))) - (invalidate-rect or/c)] - [else - (for-each invalidate-rect rects)])))) + (define-values (_1 text-height _2 _3) (send dc get-text-extent "Label" #f #f 0)) + (define parents-and-children (append (get-all-parents snip) + (get-all-children snip))) + (define rects (get-rectangles snip parents-and-children)) + (for ([rect (in-list rects)]) + (save-rectangle-to-invalidate + (- (rect-left rect) text-height) + (- (rect-top rect) text-height) + (+ (rect-right rect) text-height) + (+ (rect-bottom rect) text-height))))) - ;; (listof rect) -> (listof rect) - (define/private (eliminate-redundancies rects) - (let loop ([rects rects] - [acc null]) - (cond - [(null? rects) acc] - [else (let ([r (car rects)]) - (cond - [(or (ormap (lambda (other-rect) (rect-included-in? r other-rect)) - (cdr rects)) - (ormap (lambda (other-rect) (rect-included-in? r other-rect)) - acc)) - (loop (cdr rects) - acc)] - [else - (loop (cdr rects) - (cons r acc))]))]))) + (define pending-invalidate-rectangle #f) + (define pending-invalidate-rectangle-timer #f) + (inherit invalidate-bitmap-cache) + (define/private (run-pending-invalidate-rectangle) + (define the-pending-invalidate-rectangle pending-invalidate-rectangle) + (set! pending-invalidate-rectangle #f) + (invalidate-bitmap-cache . the-pending-invalidate-rectangle)) - ;; rect-included-in? : rect rect -> boolean - (define/private (rect-included-in? r1 r2) - (and ((rect-left r1) . >= . (rect-left r2)) - ((rect-top r1) . >= . (rect-top r2)) - ((rect-right r1) . <= . (rect-right r2)) - ((rect-bottom r1) . <= . (rect-bottom r2)))) + (define/private (save-rectangle-to-invalidate l t r b) + (unless pending-invalidate-rectangle-timer + (set! pending-invalidate-rectangle-timer + (new timer% [notify-callback + (λ () (run-pending-invalidate-rectangle))]))) + (add-to-pending-indvalidate-rectangle l t r b) + (send pending-invalidate-rectangle-timer start 20 #t)) + + (define/private (add-to-pending-indvalidate-rectangle l t r b) + (set! pending-invalidate-rectangle + (match pending-invalidate-rectangle + [(list l2 t2 r2 b2) + (list (min l l2) (min t t2) (max r r2) (max b b2))] + [#f + (list l t r b)]))) ;; get-rectangles : snip (listof snip) -> rect ;; computes the rectangles that need to be invalidated for connecting @@ -519,7 +504,11 @@ (let ([old-font (send dc get-font)]) (when edge-label-font (send dc set-font edge-label-font)) - (draw-edges dc left top right bottom dx dy) + (cond + [pending-invalidate-rectangle + (add-to-pending-indvalidate-rectangle left top right bottom)] + [else + (draw-edges dc left top right bottom dx dy)]) (when edge-label-font (send dc set-font old-font)))) (super on-paint before? dc left top right bottom dx dy draw-caret)) diff --git a/collects/mrlib/private/regmk.rkt b/collects/mrlib/private/regmk.rkt index bf5d8bf1..a6401351 100644 --- a/collects/mrlib/private/regmk.rkt +++ b/collects/mrlib/private/regmk.rkt @@ -1,6 +1,9 @@ -#lang racket +#lang racket/base + +(require (for-syntax racket/base)) + (provide define-struct/reg-mk - id->constructor + id->constructor (struct-out point) (struct-out bb)) diff --git a/collects/mrlib/scribblings/switchable-button.scrbl b/collects/mrlib/scribblings/switchable-button.scrbl index df25e4cb..74d040a2 100644 --- a/collects/mrlib/scribblings/switchable-button.scrbl +++ b/collects/mrlib/scribblings/switchable-button.scrbl @@ -15,7 +15,7 @@ @defconstructor/auto-super[([label string?] [callback (-> (is-a?/c switchable-button%) any/c)] [bitmap (is-a?/c bitmap%)] - [alternate-bitmap (is-a?/c bitmap%) bitmap] + [alternate-bitmap (is-a?/c bitmap%) bitmap] [vertical-tight? boolean? #f])]{ The @racket[callback] is called when the button is pressed. The @racket[string] and @racket[bitmap] are diff --git a/collects/scribblings/framework/color.scrbl b/collects/scribblings/framework/color.scrbl index 646e96c9..4407978c 100644 --- a/collects/scribblings/framework/color.scrbl +++ b/collects/scribblings/framework/color.scrbl @@ -154,6 +154,17 @@ Sets the currently active regions to be @racket[regions]. } + + @defmethod[(get-spell-check-strings) boolean?]{ + Returns @racket[#t] if the colorer will attempt to + spell-check string constants. + } + + @defmethod[(set-spell-check-strings [b? boolean?]) void?]{ + If called with @racket[#t], tell the colorer to spell-check + string constants. Otherwise, disable spell-checking of constants. + } + @defmethod*[(((get-regions) (listof (list/c number? (or/c (quote end) number?)))))]{ This returns the list of regions that are currently being colored in the editor. diff --git a/collects/scribblings/framework/splash.scrbl b/collects/scribblings/framework/splash.scrbl index fc61340e..3de13845 100644 --- a/collects/scribblings/framework/splash.scrbl +++ b/collects/scribblings/framework/splash.scrbl @@ -26,7 +26,7 @@ that number to control the gauge along the bottom of the splash screen. [splash-title string?] [width-default exact-nonnegative-integer?] [#:allow-funny? allow-funny? boolean? #f] - [#:frame-icon + [#:frame-icon frame-icon (or/c #f (is-a?/c bitmap%) diff --git a/collects/scribblings/gui/editor-intf.scrbl b/collects/scribblings/gui/editor-intf.scrbl index 4555fda0..7f16be31 100644 --- a/collects/scribblings/gui/editor-intf.scrbl +++ b/collects/scribblings/gui/editor-intf.scrbl @@ -1,5 +1,9 @@ #lang scribble/doc -@(require "common.rkt") +@(require "common.rkt" + scribble/eval) + +@(define editor-eval (make-base-eval)) +@(editor-eval '(require racket/class)) @definterface/title[editor<%> ()]{ @@ -206,7 +210,52 @@ See also @method[editor<%> refresh-delayed?] and @method[editor<%> If the @racket[undoable?] flag is @racket[#f], then the changes made in the sequence cannot be reversed through the @method[editor<%> - undo] method. This flag is only effective for the outermost + undo] method. To accomplish this, the editor just does not add + entries to the undo log when in an edit sequence where the + @racket[undoable?] flag is @racket[#f]. So, for example, if an + @litchar{a} is inserted into the editor and then a @litchar{b} + is inserted, and then an un-undoable edit-sequence begins, + and the @litchar{a} is colored red, and then the edit-sequence ends, + then an undo will remove the @litchar{b}, leaving the @litchar{a} + colored red. + + This behavior also means that editors can get confused. Consider + this program: + @examples[#:eval + editor-eval + (eval:alts (define t (new text%)) + ;; this is a pretty horrible hack, but + ;; the sequence of calls below behaves + ;; the way they are predicted to as of + ;; the moment of this commit + (define t + (new (class object% + (define/public (set-max-undo-history x) (void)) + (define/public (insert . args) (void)) + (define/public (begin-edit-sequence a b) (void)) + (define/public (end-edit-sequence) (void)) + (define/public (undo) (void)) + (define first? #t) + (define/public (get-text) + (cond + [first? + (set! first? #f) + "cab"] + [else "cb"])) + (super-new))))) + (send t set-max-undo-history 'forever) + (send t insert "a") + (send t insert "b") + (send t begin-edit-sequence #f #f) + (send t insert "c" 0 0) + (send t end-edit-sequence) + (send t get-text) + (send t undo) + (send t get-text)] + You might hope that the undo would remove the @litchar{b}, but it removes + the @litchar{a}. + + The @racket[undoable?] flag is only effective for the outermost @method[editor<%> begin-edit-sequence] when nested sequences are used. Note that, for a @racket[text%] object, the character-inserting version of @method[text% insert] interferes with sequence-based undo diff --git a/collects/scribblings/gui/list-box-class.scrbl b/collects/scribblings/gui/list-box-class.scrbl index 7506d859..1c5d438c 100644 --- a/collects/scribblings/gui/list-box-class.scrbl +++ b/collects/scribblings/gui/list-box-class.scrbl @@ -157,16 +157,6 @@ style. The new column is logically the last column, and it is initially displayed as the last column.} -@defmethod[(delete [n exact-nonnegative-integer?]) - void?]{ - -Deletes the item indexed by @racket[n]. @|lbnumnote| If @racket[n] is equal - to or larger than the number of items in the control, @|MismatchExn|. - -Selected items that are not deleted remain selected, and no other - items are selected.} - - @defmethod[(delete-column [n exact-nonnegative-integer?]) void?]{ diff --git a/collects/scribblings/gui/list-control-intf.scrbl b/collects/scribblings/gui/list-control-intf.scrbl index 3c035271..4b04a930 100644 --- a/collects/scribblings/gui/list-control-intf.scrbl +++ b/collects/scribblings/gui/list-control-intf.scrbl @@ -36,11 +36,22 @@ Removes all user-selectable items from the control. } +@defmethod[(delete [n exact-nonnegative-integer?]) + void?]{ + +Deletes the item indexed by @racket[n] (where items are indexed + from @racket[0]). If @racket[n] is equal + to or larger than the number of items in the control, @|MismatchExn|. + +Selected items that are not deleted remain selected, and no other + items are selected.} + + @defmethod[(find-string [s string?]) (or/c exact-nonnegative-integer? #f)]{ Finds a user-selectable item matching the given string. If no matching choice is found, @racket[#f] is returned, otherwise the index of the - matching choice is returned (items are indexed from @racket[0]). + matching choice is returned (where items are indexed from @racket[0]). } @@ -53,7 +64,7 @@ Returns the number of user-selectable items in the control (which is @defmethod[(get-selection) (or/c exact-nonnegative-integer? #f)]{ -Returns the index of the currently selected item (items are indexed +Returns the index of the currently selected item (where items are indexed from @racket[0]). If the choice item currently contains no choices or no selections, @racket[#f] is returned. If multiple selections are allowed and multiple items are selected, the index of the first @@ -64,7 +75,7 @@ Returns the index of the currently selected item (items are indexed @defmethod[(get-string [n exact-nonnegative-integer?]) (and/c immutable? label-string?)]{ -Returns the item for the given index (items are indexed from +Returns the item for the given index (where items are indexed from @racket[0]). If the provided index is larger than the greatest index in the list control, @|MismatchExn|. @@ -81,7 +92,7 @@ Returns the currently selected item. If the control currently @defmethod[(set-selection [n exact-nonnegative-integer?]) void?]{ -Selects the item specified by the given index (items are indexed from +Selects the item specified by the given index (where items are indexed from @racket[0]). If the given index larger than the greatest index in the list control, @|MismatchExn|. diff --git a/collects/scribblings/gui/menu-item-intf.scrbl b/collects/scribblings/gui/menu-item-intf.scrbl index 68256560..7f86372a 100644 --- a/collects/scribblings/gui/menu-item-intf.scrbl +++ b/collects/scribblings/gui/menu-item-intf.scrbl @@ -10,7 +10,7 @@ A @racket[menu-item<%>] object is an element within a @racket[menu%], @racket[menu-item<%>] object. A menu item is either a @racket[separator-menu-item%] object (merely - a separator), of a @racket[labelled-menu-item<%>] object; the latter + a separator), or a @racket[labelled-menu-item<%>] object; the latter is more specifically an instance of either @racket[menu-item%] (a plain menu item), @racket[checkable-menu-item%] (a checkable menu item), or @racket[menu%] (a submenu). diff --git a/collects/scribblings/gui/miscwin-funcs.scrbl b/collects/scribblings/gui/miscwin-funcs.scrbl index 441b46b5..a777274f 100644 --- a/collects/scribblings/gui/miscwin-funcs.scrbl +++ b/collects/scribblings/gui/miscwin-funcs.scrbl @@ -194,6 +194,15 @@ break is sent (via @racket[break-thread]) to the created eventspace's @tech{handler thread}.} +@defproc[(get-current-mouse-state) (values (is-a?/c point%) + (listof (or/c 'left 'middle 'right + 'shift 'control 'alt 'meta 'caps)))]{ + +Returns the current location of the mouse in screen coordinates, +and returns a list of symbols for mouse buttons and modifier keys +that are currently pressed.} + + @defproc[(hide-cursor-until-moved) void?]{ Hides the cursor until the user moves the mouse or clicks the mouse diff --git a/collects/scribblings/gui/win-overview.scrbl b/collects/scribblings/gui/win-overview.scrbl index a3585dd3..5c2a5e9d 100644 --- a/collects/scribblings/gui/win-overview.scrbl +++ b/collects/scribblings/gui/win-overview.scrbl @@ -951,6 +951,23 @@ Along similar lines, if a button callback captures a continuation captured during a button callback is therefore potentially useful outside of the same callback. +@subsection{Logging} + +The GUI system logs the timing of when events are handled and how +long they take to be handled. Each event that involves a callback +into Racket code has two events logged, both of which use +the @racket[gui-event] struct: +@racketblock[(struct gui-event (start end name) #:prefab)] +The @racket[_start] field is the result of @racket[(current-inexact-milliseconds)] +when the event handling starts. The @racket[_end] field is +@racket[#f] for the log message when the event handling starts, +and the result of @racket[(current-inexact-milliseconds)] when +it finishes for the log message when an event finishes. +The @racket[_name] field is +the name of the function that handled the event; in the case of a +@racket[queue-callback]-based event, it is the name of the thunk passed to +@racket[queue-callback]. + @section[#:tag "animation"]{Animation in Canvases} The content of a canvas is buffered, so if a canvas must be redrawn, diff --git a/collects/tests/gracket/editor.rktl b/collects/tests/gracket/editor.rktl index 41532ae5..d70c33ad 100644 --- a/collects/tests/gracket/editor.rktl +++ b/collects/tests/gracket/editor.rktl @@ -304,6 +304,62 @@ (test #f 'peek-t (peek-byte-or-special i 0)) (test 49 'read-1 (peek-byte-or-special i 1)))) +(let () + (define t (new text%)) + (send t insert "aa\nbb\ncc\ndd\nee\nff\n") + (send t insert (make-object image-snip% + (collection-file-path "recycle.png" "icons"))) + + (define p (open-input-text-editor t)) + + (define rev-at-start (send t get-revision-number)) + (define line1 (read-line p)) + + (define sl (send t get-style-list)) + (define d (make-object style-delta% 'change-bold)) + (define s (send sl find-or-create-style (send sl basic-style) d)) + (send t change-style s 6 7) + + (define rev-after-cs (send t get-revision-number)) + (define line2 (read-line p)) + + (test #t 'revision-changed (> rev-after-cs rev-at-start)) + (test "aa" 'revision-changed-line1 line1) + (test "bb" 'revision-changed-line1 line2)) + +(let () + (define t (new text%)) + (send t insert "abcd\n") + (send t insert (make-object image-snip% + (collection-file-path "recycle.png" "icons"))) + + (define (count-snips) + (let loop ([s (send t find-first-snip)]) + (cond + [s (+ 1 (loop (send s next)))] + [else 0]))) + + (send t split-snip 1) + (define before-snip-count (count-snips)) + (define rev-at-start (send t get-revision-number)) + + (define p (open-input-text-editor t)) + + (define char1 (read-char p)) + + (define s (send (send t get-style-list) basic-style)) + (send t change-style s 0 4) + (define after-snip-count (count-snips)) + (define rev-after-cs (send t get-revision-number)) + + (define chars (string (read-char p) (read-char p) (read-char p))) + + (test 4 'snips-joined1 before-snip-count) + (test 3 'snips-joined2 after-snip-count) + (test #t 'snips-joined3 (> rev-after-cs rev-at-start)) + (test #\a 'snips-joined4 char1) + (test "bcd" 'snips-joined5 chars)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Snips and Streams ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -325,6 +381,7 @@ snip)) (super-instantiate ()))) + (define snip-class (make-object (mk-number-snip-class% #t))) (send snip-class set-classname (format "~s" `(lib "number-snip.ss" "drscheme" "private"))) (send (get-the-snip-class-list) add snip-class) diff --git a/collects/tests/gracket/item.rkt b/collects/tests/gracket/item.rkt index 7c3da066..dbc19149 100644 --- a/collects/tests/gracket/item.rkt +++ b/collects/tests/gracket/item.rkt @@ -1556,13 +1556,11 @@ (when (<= 0 p (sub1 (length actual-content))) (set! actual-content (gone actual-content p)) (set! actual-user-data (gone actual-user-data p)))) - (define db (if list? - (make-object button% - "Delete" cdp - (lambda (b e) - (let ([p (send c get-selection)]) - (delete p)))) - null)) + (define db (make-object button% + "Delete" cdp + (lambda (b e) + (let ([p (send c get-selection)]) + (delete p))))) (define dab (if list? (make-object button% "Delete Above" cdp @@ -2291,6 +2289,30 @@ '(arrow bullseye cross hand ibeam watch blank size-n/s size-e/w size-ne/sw size-nw/se)) (send f show #t)) +;---------------------------------------------------------------------- + +(define (mouse) + (define f (new frame% + [label "Mouse"] + [width 300] + [height 200])) + (define m (new message% + [parent f] + [label ""] + [stretchable-width #t])) + (send f show #t) + (thread (lambda () + (let loop () + (when (send f is-shown?) + (sleep 0.1) + (define-values (pos keys) (get-current-mouse-state)) + (queue-callback + (lambda () (send m set-label + (format "~a,~a ~a" + (send pos get-x) + (send pos get-y) + keys)))) + (loop)))))) ;---------------------------------------------------------------------- @@ -2372,6 +2394,8 @@ (make-object vertical-pane% crp) ; filler (make-object button% "Cursors" crp (lambda (b e) (cursors))) (make-object vertical-pane% crp) ; filler +(make-object button% "Mouse" crp (lambda (b e) (mouse))) +(make-object vertical-pane% crp) ; filler (make-object button% "Make Radiobox Frame" crp (lambda (b e) (radiobox-frame))) (define cp (make-object horizontal-pane% ap)) (send cp stretchable-width #f) diff --git a/collects/tests/gracket/mem.rkt b/collects/tests/gracket/mem.rkt index 296104d9..ba7d3407 100644 --- a/collects/tests/gracket/mem.rkt +++ b/collects/tests/gracket/mem.rkt @@ -21,8 +21,8 @@ (define allocated '()) (define (remember tag v) (set! allocated - (cons (cons tag (make-weak-box v)) - allocated)) + (cons (cons tag (make-weak-box v)) + allocated)) v) (define sub-collect-frame @@ -71,163 +71,163 @@ (unless (zero? n) (let ([tag (cons id n)]) (let* ([edit (remember tag (make-object text%))] - [ef (let ([f (make-object frame% "Editor Frame")]) - (send (make-object editor-canvas% f) set-editor edit) - (remember tag f))] - [c (make-custodian)] - [es (parameterize ([current-custodian c]) - (make-eventspace))]) + [ef (let ([f (make-object frame% "Editor Frame")]) + (send (make-object editor-canvas% f) set-editor edit) + (remember tag f))] + [c (make-custodian)] + [es (parameterize ([current-custodian c]) + (make-eventspace))]) - (when edit? - (send ef show #t) - (sleep 0.1)) + (when edit? + (send ef show #t) + (sleep 0.1)) - (parameterize ([current-eventspace es]) - (send (remember - tag - (make-object - (class timer% + (parameterize ([current-eventspace es]) + (send (remember + tag + (make-object + (class timer% (init-rest args) - (override* [notify (lambda () (void))]) + (override* [notify (lambda () (void))]) (apply super-make-object args)))) - start 100)) + start 100)) - (when frame? - (let* ([f (remember tag - (make-object (if (even? n) - frame% - dialog%) - "Tester" #f 200 200))] - [cb (lambda (x y) f)] - [p (remember tag (make-object (get-pane% n) f))]) - (remember tag (make-object canvas% f)) - (when (zero? (modulo n 3)) - (thread (lambda () (send f show #t))) - (let loop () (sleep) (unless (send f is-shown?) (loop)))) - (remember tag (make-object button% "one" p cb)) - (let ([class check-box%]) - (let loop ([m 10]) - (unless (zero? m) - (remember (cons tag m) - (make-object class "another" p cb)) - (loop (sub1 m))))) - (remember tag (make-object check-box% "check" p cb)) - (remember tag (make-object choice% "choice" '("a" "b" "c") p cb)) - (remember tag (make-object list-box% "list" '("apple" "banana" "coconut") - p cb)) - (remember tag (make-object button% "two" p cb)) - (send f show #f))) + (when frame? + (let* ([f (remember tag + (make-object (if (even? n) + frame% + dialog%) + "Tester" #f 200 200))] + [cb (lambda (x y) f)] + [p (remember tag (make-object (get-pane% n) f))]) + (remember tag (make-object canvas% f)) + (when (zero? (modulo n 3)) + (thread (lambda () (send f show #t))) + (let loop () (sleep) (unless (send f is-shown?) (loop)))) + (remember tag (make-object button% "one" p cb)) + (let ([class check-box%]) + (let loop ([m 10]) + (unless (zero? m) + (remember (cons tag m) + (make-object class "another" p cb)) + (loop (sub1 m))))) + (remember tag (make-object check-box% "check" p cb)) + (remember tag (make-object choice% "choice" '("a" "b" "c") p cb)) + (remember tag (make-object list-box% "list" '("apple" "banana" "coconut") + p cb)) + (remember tag (make-object button% "two" p cb)) + (send f show #f))) - (when subwindows? - (let ([p (make-object (get-panel% n) sub-collect-frame)] - [cv (make-object canvas% sub-collect-frame)] - [add-objects - (lambda (p tag hide?) - (let ([b (let* ([x #f] - [bcb (lambda (a b) x)]) - (set! x (make-object button% "one" p bcb)) - x)] - [c (make-object check-box% "check" p void)] - [co (make-object choice% "choice" '("a" "b" "c") p void)] - [cv (make-object canvas% p)] - [lb (make-object list-box% "list" '("apple" "banana" "coconut") p void)]) - (when hide? - (send p delete-child b) - (send p delete-child c) - (send p delete-child cv) - (send p delete-child co) - (send p delete-child lb)) - (remember tag b) - (remember tag c) - (remember tag cv) - (remember tag co) - (remember tag lb)))]) - (add-objects sub-collect-panel (cons 'sc1 tag) #t) - (add-objects p (cons 'sc2 tag) #f) - (remember (cons 'sc0 tag) p) - (remember (cons 'sc0 tag) cv) - (send sub-collect-frame delete-child p) - (send sub-collect-frame delete-child cv))) + (when subwindows? + (let ([p (make-object (get-panel% n) sub-collect-frame)] + [cv (make-object canvas% sub-collect-frame)] + [add-objects + (lambda (p tag hide?) + (let ([b (let* ([x #f] + [bcb (lambda (a b) x)]) + (set! x (make-object button% "one" p bcb)) + x)] + [c (make-object check-box% "check" p void)] + [co (make-object choice% "choice" '("a" "b" "c") p void)] + [cv (make-object canvas% p)] + [lb (make-object list-box% "list" '("apple" "banana" "coconut") p void)]) + (when hide? + (send p delete-child b) + (send p delete-child c) + (send p delete-child cv) + (send p delete-child co) + (send p delete-child lb)) + (remember tag b) + (remember tag c) + (remember tag cv) + (remember tag co) + (remember tag lb)))]) + (add-objects sub-collect-panel (cons 'sc1 tag) #t) + (add-objects p (cons 'sc2 tag) #f) + (remember (cons 'sc0 tag) p) + (remember (cons 'sc0 tag) cv) + (send sub-collect-frame delete-child p) + (send sub-collect-frame delete-child cv))) - (when (and edit? insert?) - (let ([e edit]) + (when (and edit? insert?) + (let ([e edit]) (send e begin-edit-sequence) - (when load-file? - (send e load-file (build-path source-dir "mem.rkt"))) - (let loop ([i 20]) - (send e insert (number->string i)) - (unless (zero? i) - (loop (sub1 i)))) - (let ([s (make-object editor-snip%)]) - (send (send s get-editor) insert "Hello!") - (send e insert s)) - (send e insert #\newline) - (send e insert "done") - (send e set-modified #f) + (when load-file? + (send e load-file (build-path source-dir "mem.rkt"))) + (let loop ([i 20]) + (send e insert (number->string i)) + (unless (zero? i) + (loop (sub1 i)))) + (let ([s (make-object editor-snip%)]) + (send (send s get-editor) insert "Hello!") + (send e insert s)) + (send e insert #\newline) + (send e insert "done") + (send e set-modified #f) (send e end-edit-sequence))) - - (when menus? - (let ([f (remember tag (make-object frame% "MB Frame 0"))]) - (remember tag (make-object menu% "TM1" (remember (cons 'q tag) (make-object menu-bar% f))))) - (let* ([mb (remember tag (make-object menu-bar% ef))] - [m (remember tag (make-object menu% "Ok" mb))]) - (remember tag (make-object menu-item% "Hi" m void)) - (remember tag (make-object menu-item% "There" m void #\t)) - (remember tag - (make-object checkable-menu-item% - "Checkable" - (remember tag (make-object menu% "Hello" m)) - void)) - (let ([i (remember tag (make-object menu-item% "Delete Me" m void))]) - (send i delete))) + + (when menus? + (let ([f (remember tag (make-object frame% "MB Frame 0"))]) + (remember tag (make-object menu% "TM1" (remember (cons 'q tag) (make-object menu-bar% f))))) + (let* ([mb (remember tag (make-object menu-bar% ef))] + [m (remember tag (make-object menu% "Ok" mb))]) + (remember tag (make-object menu-item% "Hi" m void)) + (remember tag (make-object menu-item% "There" m void #\t)) + (remember tag + (make-object checkable-menu-item% + "Checkable" + (remember tag (make-object menu% "Hello" m)) + void)) + (let ([i (remember tag (make-object menu-item% "Delete Me" m void))]) + (send i delete))) - (when subwindows? - (unless permanent-ready? - (semaphore-wait mb-lock) - (unless (send sub-collect-frame get-menu-bar) - (let ([mb (make-object menu-bar% sub-collect-frame)]) - (make-object menu% "Permanent" mb))) - (set! permanent-ready? #t) - (semaphore-post mb-lock)) - (let* ([mb (send sub-collect-frame get-menu-bar)] - [mm (car (send mb get-items))]) - (send (remember (cons 'm tag) (make-object menu-item% "Delete Me" mm void)) delete) - (let ([m (remember tag (make-object menu% "Temporary" mb))]) - (remember (cons 't tag) (make-object menu-item% "Temp Hi" m void)) - (send m delete))))) - - (when atomic? - (let loop ([m 8]) - (unless (zero? m) - (remember (cons tag m) (make-object point% n m)) - (let ([br (make-object brush%)]) - (remember (cons tag m) br) - (hash-set! htw br 'ok)) - (remember (cons tag m) (make-object pen%)) - (loop (sub1 m))))) - - (when offscreen? - (let ([m (remember tag (make-object bitmap-dc%))] - [b0 (remember (cons tag 'f) (make-object bitmap% (get-image n)))] - [b (remember (cons tag 'u) (make-object bitmap% 100 100))] - [b2 (remember (cons tag 'x) (make-object bitmap% 100 100))]) - (unless (send b0 ok?) - (error "bitmap load error")) - (send m set-bitmap b))) - - (when edit? - (send ef show #f)) - - (custodian-shutdown-all c) + (when subwindows? + (unless permanent-ready? + (semaphore-wait mb-lock) + (unless (send sub-collect-frame get-menu-bar) + (let ([mb (make-object menu-bar% sub-collect-frame)]) + (make-object menu% "Permanent" mb))) + (set! permanent-ready? #t) + (semaphore-post mb-lock)) + (let* ([mb (send sub-collect-frame get-menu-bar)] + [mm (car (send mb get-items))]) + (send (remember (cons 'm tag) (make-object menu-item% "Delete Me" mm void)) delete) + (let ([m (remember tag (make-object menu% "Temporary" mb))]) + (remember (cons 't tag) (make-object menu-item% "Temp Hi" m void)) + (send m delete))))) - (collect-garbage) + (when atomic? + (let loop ([m 8]) + (unless (zero? m) + (remember (cons tag m) (make-object point% n m)) + (let ([br (make-object brush%)]) + (remember (cons tag m) br) + (hash-set! htw br 'ok)) + (remember (cons tag m) (make-object pen%)) + (loop (sub1 m))))) + + (when offscreen? + (let ([m (remember tag (make-object bitmap-dc%))] + [b0 (remember (cons tag 'f) (make-object bitmap% (get-image n)))] + [b (remember (cons tag 'u) (make-object bitmap% 100 100))] + [b2 (remember (cons tag 'x) (make-object bitmap% 100 100))]) + (unless (send b0 ok?) + (error "bitmap load error")) + (send m set-bitmap b))) + + (when edit? + (send ef show #f)) + + (custodian-shutdown-all c) - (maker id (sub1 n)))))) + (collect-garbage) + + (maker id (sub1 n)))))) (define (still) (map (lambda (x) - (let ([v (weak-box-value (cdr x))]) - (when v + (let ([v (weak-box-value (cdr x))]) + (when v (printf "~s ~s\n" (car x) v)))) allocated) (void)) @@ -241,29 +241,29 @@ (define (breakable t) (if #f (thread (lambda () - (read) - (printf "breaking\n") - (break-thread t) - (thread-wait t) - (printf "done\n"))) + (read) + (printf "breaking\n") + (break-thread t) + (thread-wait t) + (printf "done\n"))) (void))) (define (do-test) (let ([sema (make-semaphore)]) (let loop ([n num-threads]) (unless (zero? n) - (breakable - (thread (lambda () - (stw (current-thread) n) - (dynamic-wind - void - (lambda () (maker n num-times)) - (lambda () (semaphore-post sema)))))) - (loop (sub1 n)))) + (breakable + (thread (lambda () + (stw (current-thread) n) + (dynamic-wind + void + (lambda () (maker n num-times)) + (lambda () (semaphore-post sema)))))) + (loop (sub1 n)))) (let loop ([n num-threads]) (unless (zero? n) - (yield sema) - (loop (sub1 n))))) + (yield sema) + (loop (sub1 n))))) (collect-garbage) (collect-garbage) @@ -280,4 +280,3 @@ (still))) (do-test) - diff --git a/collects/tests/utils/gui.rkt b/collects/tests/utils/gui.rkt index 069e29d3..b4709ac1 100644 --- a/collects/tests/utils/gui.rkt +++ b/collects/tests/utils/gui.rkt @@ -1,8 +1,10 @@ -(module gui mzscheme - (require mred - mzlib/class - mzlib/etc) - (provide find-labelled-window whitespace-string=?) +#lang racket/base + + (require racket/gui/base + racket/class) + (provide find-labelled-window + find-labelled-windows + whitespace-string=?) ;; whitespace-string=? : string string -> boolean ;; determines if two strings are equal, up to their whitespace. @@ -60,59 +62,64 @@ [else #f]))) ;; whitespace-string=? tests - '(map (lambda (x) (apply equal? x)) - (list (list #t (whitespace-string=? "a" "a")) - (list #f (whitespace-string=? "a" "A")) - (list #f (whitespace-string=? "a" " ")) - (list #f (whitespace-string=? " " "A")) - (list #t (whitespace-string=? " " " ")) - (list #t (whitespace-string=? " " " ")) - (list #t (whitespace-string=? " " " ")) - (list #t (whitespace-string=? " " " ")) - (list #t (whitespace-string=? "a a" "a a")) - (list #t (whitespace-string=? "a a" "a a")) - (list #t (whitespace-string=? "a a" "a a")) - (list #t (whitespace-string=? " a" "a")) - (list #t (whitespace-string=? "a" " a")) - (list #t (whitespace-string=? "a " "a")) - (list #t (whitespace-string=? "a" "a ")))) + (module+ test + (require rackunit) + (check-equal? #t (whitespace-string=? "a" "a")) + (check-equal? #f (whitespace-string=? "a" "A")) + (check-equal? #f (whitespace-string=? "a" " ")) + (check-equal? #f (whitespace-string=? " " "A")) + (check-equal? #t (whitespace-string=? " " " ")) + (check-equal? #t (whitespace-string=? " " " ")) + (check-equal? #t (whitespace-string=? " " " ")) + (check-equal? #t (whitespace-string=? " " " ")) + (check-equal? #t (whitespace-string=? "a a" "a a")) + (check-equal? #t (whitespace-string=? "a a" "a a")) + (check-equal? #t (whitespace-string=? "a a" "a a")) + (check-equal? #t (whitespace-string=? " a" "a")) + (check-equal? #t (whitespace-string=? "a" " a")) + (check-equal? #t (whitespace-string=? "a " "a")) + (check-equal? #t (whitespace-string=? "a" "a "))) ;;; find-labelled-window : (union ((union #f string) -> window<%>) ;;; ((union #f string) (union #f class) -> window<%>) ;;; ((union #f string) (union class #f) area-container<%> -> window<%>)) ;;;; may call error, if no control with the label is found - (define find-labelled-window - (opt-lambda (label - [class #f] - [window (get-top-level-focus-window)] - [failure (lambda () - (error 'find-labelled-window "no window labelled ~e in ~e~a" - label - window - (if class - (format " matching class ~e" class) - "")))]) - (unless (or (not label) - (string? label)) - (error 'find-labelled-window "first argument must be a string or #f, got ~e; other args: ~e ~e" - label class window)) - (unless (or (class? class) - (not class)) - (error 'find-labelled-window "second argument must be a class or #f, got ~e; other args: ~e ~e" - class label window)) - (unless (is-a? window area-container<%>) - (error 'find-labelled-window "third argument must be a area-container<%>, got ~e; other args: ~e ~e" - window label class)) - (let ([ans - (let loop ([window window]) - (cond - [(and (or (not class) - (is-a? window class)) - (let ([win-label (and (is-a? window window<%>) - (send window get-label))]) - (equal? label win-label))) - window] - [(is-a? window area-container<%>) (ormap loop (send window get-children))] - [else #f]))]) - (or ans - (failure)))))) + (define (find-labelled-window label + [class #f] + [window (get-top-level-focus-window)] + [failure (λ () + (error 'find-labelled-window "no window labelled ~e in ~e~a" + label + window + (if class + (format " matching class ~e" class) + "")))]) + (define windows (find-labelled-windows label class window)) + (cond + [(null? windows) (failure)] + [else (car windows)])) + + (define (find-labelled-windows label [class #f] [window (get-top-level-focus-window)]) + (unless (or (not label) + (string? label)) + (error 'find-labelled-windows "first argument must be a string or #f, got ~e; other args: ~e ~e" + label class window)) + (unless (or (class? class) + (not class)) + (error 'find-labelled-windows "second argument must be a class or #f, got ~e; other args: ~e ~e" + class label window)) + (unless (is-a? window area-container<%>) + (error 'find-labelled-windows "third argument must be a area-container<%>, got ~e; other args: ~e ~e" + window label class)) + (let loop ([window window]) + (cond + [(and (or (not class) + (is-a? window class)) + (let ([win-label (and (is-a? window window<%>) + (send window get-label))]) + (equal? label win-label))) + (list window)] + [(is-a? window area-container<%>) (apply append (map loop (send window get-children)))] + [else '()]))) + +