suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

improve drracket's response to an unhappy aspell program

Browse Source 
Specifically, two things:

 - make drracket more careful to not crash when aspell
   doesn't behave, and

 - have a more careful test when clicking the menu item
   (it now does a trial run of aspell instead of just
    looking for the binary)

closes PR 13242 (I realize there is still a feature
request mentioned in the audit trail of that PR, but
since the main problem is fixed, I'll consider that
to just be something separate)

original commit: c5330194a9a992a8f34781327ff0975624399660
This commit is contained in:
Robby Findler 2012-11-10 12:56:16 -06:00
commit 0d6bebe533
51 changed files with 1496 additions and 790 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/framework/main.rkt
View File

@ -72,6 +72,12 @@
in a GUI, and the color to use. The colors are used to show the nesting in a GUI, and the color to use. The colors are used to show the nesting
structure in the parens.}) 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 (proc-doc/names
text:range? (-> any/c boolean?) (arg) text:range? (-> any/c boolean?) (arg)
@{Determines if @racket[arg] is an instance of the @tt{range} struct.}) @{Determines if @racket[arg] is an instance of the @tt{range} struct.})

64
collects/framework/private/aspell.rkt
View File

@ -1,11 +1,14 @@
#lang racket/base #lang racket/base
(require racket/system (require racket/system
racket/match racket/match
racket/contract) racket/contract
racket/port
string-constants)
(provide/contract (provide/contract
[query-aspell (-> (and/c string? (not/c #rx"[\n]")) (listof (list/c number? number?)))] [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 (define aspell-candidate-paths
'("/usr/bin" '("/usr/bin"
@ -25,6 +28,41 @@
(and (file-exists? c2) (and (file-exists? c2)
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-req-chan (make-channel))
(define aspell-thread #f) (define aspell-thread #f)
(define (start-aspell-thread) (define (start-aspell-thread)
@ -40,12 +78,13 @@
(set! already-attempted-aspell? #t) (set! already-attempted-aspell? #t)
(define asp (find-aspell-binary-path)) (define asp (find-aspell-binary-path))
(when asp (when asp
(define aspell? (regexp-match? #rx"aspell" (path->string asp))) (set! aspell-proc (start-aspell asp))
(set! aspell-proc (apply process* asp "-a" (if aspell? '("--encoding=utf-8") '()))) (define line (with-handlers ((exn:fail? exn-message))
(define line (read-line (list-ref aspell-proc 0))) (read-line (list-ref aspell-proc 0))))
(log-info (format "framework: started speller: ~a" line)) (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 ;; put aspell in "terse" mode
(display "!\n" (list-ref aspell-proc 1)) (display "!\n" (list-ref aspell-proc 1))
(flush-output (list-ref aspell-proc 1))) (flush-output (list-ref aspell-proc 1)))
@ -57,11 +96,11 @@
(define l (with-handlers ((exn:fail? void)) (define l (with-handlers ((exn:fail? void))
(read-line stderr))) (read-line stderr)))
(when (string? l) (when (string? l)
(log-warning (format "aspell-proc stderr: ~a" l)) (asp-log (format "aspell-proc stderr: ~a" l))
(loop)))))))) (loop))))))))
(define (shutdown-aspell why) (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)) (define proc (list-ref aspell-proc 4))
(close-input-port (list-ref aspell-proc 0)) (close-input-port (list-ref aspell-proc 0))
(close-output-port (list-ref aspell-proc 1)) (close-output-port (list-ref aspell-proc 1))
@ -94,7 +133,12 @@
(define check-on-aspell (sync/timeout .5 stdout)) (define check-on-aspell (sync/timeout .5 stdout))
(cond (cond
[check-on-aspell [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 (cond
[(eof-object? l) [(eof-object? l)
(send-resp '()) (send-resp '())

236
collects/framework/private/color.rkt
View File

@ -6,9 +6,8 @@ added reset-regions
added get-regions added get-regions
|# |#
(require mzlib/class (require racket/class
mzlib/thread racket/gui/base
mred
syntax-color/token-tree syntax-color/token-tree
syntax-color/paren-tree syntax-color/paren-tree
syntax-color/default-lexer syntax-color/default-lexer
@ -237,13 +236,11 @@ added get-regions
(start-colorer token-sym->style get-token pairs))) (start-colorer token-sym->style get-token pairs)))
;; ---------------------- Multi-threading --------------------------- ;; ---------------------- Multi-threading ---------------------------
;; A list of (vector style number number) that indicate how to color the buffer ;; The editor revision when the last coloring was started
(define colorings null) (define revision-when-started-parsing #f)
;; The coroutine object for tokenizing the buffer
(define tok-cor #f) ;; The editor revision when after the last edit to the buffer
;; The editor revision when tok-cor was created (define revision-after-last-edit #f)
(define rev #f)
(inherit change-style begin-edit-sequence end-edit-sequence highlight-range (inherit change-style begin-edit-sequence end-edit-sequence highlight-range
get-style-list in-edit-sequence? get-start-position get-end-position get-style-list in-edit-sequence? get-start-position get-end-position
@ -275,17 +272,7 @@ added get-regions
(update-lexer-state-observers) (update-lexer-state-observers)
(set! restart-callback #f) (set! restart-callback #f)
(set! force-recolor-after-freeze #f) (set! force-recolor-after-freeze #f)
(set! colorings null) (set! revision-when-started-parsing #f))
(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 '()))
;; Discard extra tokens at the first of invalid-tokens ;; Discard extra tokens at the first of invalid-tokens
(define/private (sync-invalid ls) (define/private (sync-invalid ls)
@ -302,60 +289,83 @@ added get-regions
(set-lexer-state-invalid-tokens-mode! ls mode)) (set-lexer-state-invalid-tokens-mode! ls mode))
(sync-invalid ls)))) (sync-invalid ls))))
(define/private (re-tokenize ls in in-start-pos in-lexer-mode enable-suspend) (define/private (re-tokenize-move-to-next-ls start-time did-something?)
(enable-suspend #f) (cond
;(define-values (_line1 _col1 pos-before) (port-next-location in)) [(null? re-tokenize-lses)
(define-values (lexeme type data new-token-start new-token-end backup-delta new-lexer-mode) ;; done: return #t
(get-token in in-start-pos in-lexer-mode)) #t]
;(define-values (_line2 _col2 pos-after) (port-next-location in)) [else
(enable-suspend #t) (define ls (car re-tokenize-lses))
(unless (eq? 'eof type) (set! re-tokenize-lses (cdr re-tokenize-lses))
(unless (exact-nonnegative-integer? new-token-start) (define in
(error 'color:text<%> "expected an exact nonnegative integer for the token start, got ~e" new-token-start)) (open-input-text-editor this
(unless (exact-nonnegative-integer? new-token-end) (lexer-state-current-pos ls)
(error 'color:text<%> "expected an exact nonnegative integer for the token end, got ~e" new-token-end)) (lexer-state-end-pos ls)
(unless (exact-nonnegative-integer? backup-delta) (λ (x) #f)))
(error 'color:text<%> "expected an exact nonnegative integer for the backup delta, got ~e" backup-delta)) (port-count-lines! in)
(unless (0 . < . (- new-token-end new-token-start)) (continue-re-tokenize start-time did-something? ls in
(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)) (lexer-state-current-pos ls)
(enable-suspend #f) (lexer-state-current-lexer-mode ls))]))
#; (printf "~s at ~a to ~a\n" lexeme (+ in-start-pos (sub1 new-token-start))
(+ in-start-pos (sub1 new-token-end))) (define re-tokenize-lses #f)
(let ((len (- new-token-end new-token-start)))
#; (define/private (continue-re-tokenize start-time did-something? ls in in-start-pos lexer-mode)
(unless (= len (- pos-after pos-before)) (cond
;; this check requires the two calls to port-next-location to be also uncommented [(and did-something? ((+ start-time 20.0) . <= . (current-inexact-milliseconds)))
;; when this check fails, bad things can happen non-deterministically later on #f]
(eprintf "pos changed bad ; len ~s pos-before ~s pos-after ~s (token ~s mode ~s)\n" [else
len pos-before pos-after lexeme new-lexer-mode)) ;(define-values (_line1 _col1 pos-before) (port-next-location in))
(set-lexer-state-current-pos! ls (+ len (lexer-state-current-pos ls))) (define-values (lexeme type data new-token-start new-token-end backup-delta new-lexer-mode)
(set-lexer-state-current-lexer-mode! ls new-lexer-mode) (get-token in in-start-pos lexer-mode))
(sync-invalid ls) ;(define-values (_line2 _col2 pos-after) (port-next-location in))
(when (and should-color? (should-color-type? type) (not frozen?)) (cond
(add-colorings type in-start-pos new-token-start new-token-end)) [(eq? 'eof type)
;; Using the non-spec version takes 3 times as long as the spec (re-tokenize-move-to-next-ls start-time #t)]
;; version. In other words, the new greatly outweighs the tree [else
;; operations. (unless (exact-nonnegative-integer? new-token-start)
;;(insert-last! tokens (new token-tree% (length len) (data type))) (error 'color:text<%> "expected an exact nonnegative integer for the token start, got ~e" new-token-start))
(insert-last-spec! (lexer-state-tokens ls) len (make-data type new-lexer-mode backup-delta)) (unless (exact-nonnegative-integer? new-token-end)
#; (show-tree (lexer-state-tokens ls)) (error 'color:text<%> "expected an exact nonnegative integer for the token end, got ~e" new-token-end))
(send (lexer-state-parens ls) add-token data len) (unless (exact-nonnegative-integer? backup-delta)
(cond (error 'color:text<%> "expected an exact nonnegative integer for the backup delta, got ~e" backup-delta))
[(and (not (send (lexer-state-invalid-tokens ls) is-empty?)) (unless (new-token-start . < . new-token-end)
(= (lexer-state-invalid-tokens-start ls) (error 'color:text<%>
(lexer-state-current-pos ls)) "expected the distance between the start and end position for each token to be positive, but start was ~e and end was ~e"
(equal? new-lexer-mode new-token-start new-token-end))
(lexer-state-invalid-tokens-mode ls))) (let ((len (- new-token-end new-token-start)))
(send (lexer-state-invalid-tokens ls) search-max!) #;
(send (lexer-state-parens ls) merge-tree (unless (= len (- pos-after pos-before))
(send (lexer-state-invalid-tokens ls) get-root-end-position)) ;; this check requires the two calls to port-next-location to be also uncommented
(insert-last! (lexer-state-tokens ls) ;; when this check fails, bad things can happen non-deterministically later on
(lexer-state-invalid-tokens ls)) (eprintf "pos changed bad ; len ~s pos-before ~s pos-after ~s (token ~s mode ~s)\n"
(set-lexer-state-invalid-tokens-start! ls +inf.0) len pos-before pos-after lexeme new-lexer-mode))
(enable-suspend #t)] (set-lexer-state-current-pos! ls (+ len (lexer-state-current-pos ls)))
[else (set-lexer-state-current-lexer-mode! ls new-lexer-mode)
(enable-suspend #t) (sync-invalid ls)
(re-tokenize ls in in-start-pos new-lexer-mode enable-suspend)])))) (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/private (add-colorings type in-start-pos new-token-start new-token-end)
(define sp (+ in-start-pos (sub1 new-token-start))) (define sp (+ in-start-pos (sub1 new-token-start)))
@ -376,22 +386,23 @@ added get-regions
[lp 0]) [lp 0])
(cond (cond
[(null? spellos) [(null? spellos)
(set! colorings (cons (vector color (+ sp lp) (+ sp (string-length str))) (add-coloring color (+ sp lp) (+ sp (string-length str)))]
colorings))]
[else [else
(define err (car spellos)) (define err (car spellos))
(define err-start (list-ref err 0)) (define err-start (list-ref err 0))
(define err-len (list-ref err 1)) (define err-len (list-ref err 1))
(set! colorings (list* (vector color (+ pos lp) (+ pos err-start)) (add-coloring misspelled-color (+ pos err-start) (+ pos err-start err-len))
(vector misspelled-color (+ pos err-start) (+ pos err-start err-len)) (add-coloring color (+ pos lp) (+ pos err-start))
colorings))
(loop (cdr spellos) (+ err-start err-len))])) (loop (cdr spellos) (+ err-start err-len))]))
(loop (cdr strs) (loop (cdr strs)
(+ pos (string-length str) 1))))] (+ pos (string-length str) 1))))]
[else [else
(set! colorings (cons (vector color sp ep) colorings))])] (add-coloring color sp ep)])]
[else [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) (define/private (show-tree t)
(printf "Tree:\n") (printf "Tree:\n")
@ -486,52 +497,19 @@ added get-regions
(define/private (colorer-driver) (define/private (colorer-driver)
(unless (andmap lexer-state-up-to-date? lexer-states) (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) (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) (end-edit-sequence)
#;(printf "end coloring\n"))) (c-log "finished end-edit-sequence")))
(define/private (colorer-callback) (define/private (colorer-callback)
(cond (cond
@ -1148,3 +1126,9 @@ added get-regions
(define text-mode% (text-mode-mixin mode:surrogate-text%)) (define text-mode% (text-mode-mixin mode:surrogate-text%))
(define misspelled-text-color-style-name "Misspelled 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))))

225
collects/framework/private/follow-log.rkt Normal file
View File

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

18
collects/framework/private/frame.rkt
View File

@ -796,9 +796,14 @@
[ec (new position-canvas% [ec (new position-canvas%
[parent panel] [parent panel]
[button-up [button-up
(λ () (λ (evt)
(collect-garbage) (cond
(update-memory-text))] [(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"])]) [init-width "99.99 MB"])])
(set! memory-canvases (cons ec memory-canvases)) (set! memory-canvases (cons ec memory-canvases))
(update-memory-text) (update-memory-text)
@ -890,6 +895,7 @@
(inherit min-client-height min-client-width get-dc get-client-size refresh) (inherit min-client-height min-client-width get-dc get-client-size refresh)
(init init-width) (init init-width)
(init-field [button-up #f]) (init-field [button-up #f])
(init-field [char-typed void])
(define str "") (define str "")
(define/public (set-str _str) (define/public (set-str _str)
(set! str _str) (set! str _str)
@ -913,7 +919,11 @@
(let-values ([(cw ch) (get-client-size)]) (let-values ([(cw ch) (get-client-size)])
(when (and (<= (send evt get-x) cw) (when (and (<= (send evt get-x) cw)
(<= (send evt get-y) ch)) (<= (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))) (super-new (style '(transparent no-focus)))
(let ([dc (get-dc)]) (let ([dc (get-dc)])
(let-values ([(_1 th _2 _3) (send dc get-text-extent str)]) (let-values ([(_1 th _2 _3) (send dc get-text-extent str)])

6
collects/framework/private/keymap.rkt
View File

@ -337,7 +337,7 @@
[mouse-popup-menu [mouse-popup-menu
(λ (edit event) (λ (edit event)
(when (send event button-down?) (when (send event button-up?)
(let ([a (send edit get-admin)]) (let ([a (send edit get-admin)])
(when a (when a
(let ([m (make-object popup-menu%)]) (let ([m (make-object popup-menu%)])
@ -739,7 +739,7 @@
(send edit on-char event) (send edit on-char event)
(loop (sub1 n))))) (loop (sub1 n)))))
(λ () (λ ()
(send edit end-edit-sequence))))))) (send edit end-edit-sequence)))))))
#t)) #t))
(send km set-break-sequence-callback done) (send km set-break-sequence-callback done)
#t))] #t))]
@ -823,7 +823,7 @@
(λ (edit event) (λ (edit event)
(when building-macro (when building-macro
(set! current-macro (reverse building-macro)) (set! current-macro (reverse building-macro))
(set! build-protect? #f) (set! build-protect? #f)
(send build-macro-km break-sequence)) (send build-macro-km break-sequence))
#t)] #t)]
[delete-key [delete-key

66
collects/framework/private/logging-timer.rkt Normal file
View File

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

2
collects/framework/private/racket.rkt
View File

@ -538,7 +538,7 @@
#f)] #f)]
[last-para (and last [last-para (and last
(position-paragraph last))]) (position-paragraph last))])
(letrec (letrec
([find-offset ([find-offset
(λ (start-pos) (λ (start-pos)
(define tab-char? #f) (define tab-char? #f)

15
collects/framework/private/text.rkt
View File

@ -11,7 +11,8 @@
"autocomplete.rkt" "autocomplete.rkt"
mred/mred-sig mred/mred-sig
mrlib/interactive-value-port mrlib/interactive-value-port
racket/list) racket/list
"logging-timer.rkt")
(require setup/xref (require setup/xref
scribble/xref scribble/xref
scribble/manual-struct) scribble/manual-struct)
@ -1063,7 +1064,7 @@
(when searching-str (when searching-str
(unless timer (unless timer
(set! timer (set! timer
(new timer% (new logging-timer%
[notify-callback [notify-callback
(λ () (λ ()
(run-after-edit-sequence (run-after-edit-sequence
@ -1536,7 +1537,7 @@
;; have not yet been propogated to the delegate ;; have not yet been propogated to the delegate
(define todo '()) (define todo '())
(define timer (new timer% (define timer (new logging-timer%
[notify-callback [notify-callback
(λ () (λ ()
;; it should be the case that todo is always '() when the delegate is #f ;; 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 ;; draws line numbers on the left hand side of a text% object
(define line-numbers-mixin (define line-numbers-mixin
(mixin ((class->interface text%) editor:standard-style-list<%>) (line-numbers<%>) (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 get-visible-position-range
last-line last-line
line-location line-location
@ -4193,6 +4196,7 @@ designates the character that triggers autocompletion
(when (showing-line-numbers?) (when (showing-line-numbers?)
(define dc (get-dc)) (define dc (get-dc))
(when dc (when dc
(begin-edit-sequence #f #f)
(define bx (box 0)) (define bx (box 0))
(define by (box 0)) (define by (box 0))
(define tw (text-width dc (number-space+1))) (define tw (text-width dc (number-space+1)))
@ -4208,7 +4212,8 @@ designates the character that triggers autocompletion
tw tw
th) th)
(unless (= line (last-line)) (unless (= line (last-line))
(loop (+ line 1)))))))) (loop (+ line 1)))))
(end-edit-sequence))))
(super-new) (super-new)
(setup-padding))) (setup-padding)))

24
collects/framework/test.rkt
View File

@ -253,22 +253,26 @@
(define object-tag 'test:find-object) (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) (define (find-object obj-class b-desc)
(λ () (λ ()
(cond (cond
[(or (string? b-desc) [(or (string? b-desc)
(regexp? b-desc)
(procedure? b-desc)) (procedure? b-desc))
(let* ([active-frame (test:get-active-top-level-window)] (let* ([active-frame (test:get-active-top-level-window)]
[_ (unless active-frame [_ (unless active-frame
(error object-tag (error object-tag
"could not find object: ~a, no active frame" "could not find object: ~e, no active frame"
b-desc))] b-desc))]
[child-matches? [child-matches?
(λ (child) (λ (child)
(cond (cond
[(string? b-desc) [(string? b-desc)
(equal? (send child get-label) 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) [(procedure? b-desc)
(b-desc child)]))] (b-desc child)]))]
[found [found
@ -287,13 +291,13 @@
(send panel get-children)))]) (send panel get-children)))])
(or found (or found
(error object-tag (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 obj-class
b-desc)))] b-desc)))]
[(is-a? b-desc obj-class) b-desc] [(is-a? b-desc obj-class) b-desc]
[else (error [else (error
object-tag 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)]))) obj-class b-desc)])))
@ -317,7 +321,7 @@
[else [else
(update-control ctrl) (update-control ctrl)
(send ctrl command event) (send ctrl command event)
(void)])))))) (void)]))))))
;; ;;
;; BUTTON ;; BUTTON
@ -936,7 +940,8 @@
(proc-doc/names (proc-doc/names
test:keystroke test:keystroke
(->* ((or/c char? symbol?)) (->* ((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?) void?)
((key) ((key)
((modifier-list null))) ((modifier-list null)))
@ -973,10 +978,11 @@
(proc-doc/names (proc-doc/names
test:mouse-click test:mouse-click
(->* (->*
((symbols 'left 'middle 'right) ((or/c 'left 'middle 'right)
(and/c exact? integer?) (and/c exact? integer?)
(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?) void?)
((button x y) ((button x y)
((modifiers null))) ((modifiers null)))
@ -985,7 +991,7 @@
@method[canvas<%> on-event] method. @method[canvas<%> on-event] method.
Use @racket[test:button-push] to click on a button. 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. modifier key while clicking and @racket['middle] cannot be generated.
Under Windows, @racket['middle] can only be generated if the user has a Under Windows, @racket['middle] can only be generated if the user has a

1
collects/mred/mred-sig.rkt
View File

@ -78,6 +78,7 @@ frame%
gauge% gauge%
get-choices-from-user get-choices-from-user
get-color-from-user get-color-from-user
get-current-mouse-state
get-default-shortcut-prefix get-default-shortcut-prefix
get-directory get-directory
get-display-count get-display-count

2
collects/mred/private/moredialogs.rkt
View File

@ -329,7 +329,7 @@
(send blue get-value)))] (send blue get-value)))]
[install-color [install-color
(lambda (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 green set-value (send color green))
(send blue set-value (send color blue)) (send blue set-value (send color blue))
(send canvas refresh))]) (send canvas refresh))])

7
collects/mred/private/mrcanvas.rkt
View File

@ -19,9 +19,10 @@
(define canvas-default-size 20) ; a default size for canvases tht fits borders without losing client sizes (define canvas-default-size 20) ; a default size for canvases tht fits borders without losing client sizes
(define canvas-scroll-size 10) (define canvas-scroll-size 10)
(define canvas-control-border-extra (case (system-type) (define canvas-control-border-extra
[(windows) 2] (case (system-type)
[else 0])) [(windows) 2]
[else 0]))
(define canvas<%> (define canvas<%>
(interface (subwindow<%>) (interface (subwindow<%>)

1
collects/mred/private/mred.rkt
View File

@ -116,6 +116,7 @@
event-dispatch-handler event-dispatch-handler
eventspace? eventspace?
flush-display flush-display
get-current-mouse-state
get-highlight-background-color get-highlight-background-color
get-highlight-text-color get-highlight-text-color
get-the-editor-data-class-list get-the-editor-data-class-list

11
collects/mred/private/mritem.rkt
View File

@ -600,7 +600,10 @@
[find-string (entry-point (lambda (x) [find-string (entry-point (lambda (x)
(check-label-string '(method list-control<%> find-string) x) (check-label-string '(method list-control<%> find-string) x)
(do-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) [-append-list-string (lambda (i)
(set! content (append content (list i))))] (set! content (append content (list i))))]
[-set-list-string (lambda (i s) [-set-list-string (lambda (i s)
@ -842,11 +845,7 @@
(set! num-columns (add1 num-columns)) (set! num-columns (add1 num-columns))
(set! column-labels (append column-labels (list label))) (set! column-labels (append column-labels (list label)))
(send wx append-column 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-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-label-font (lambda () (send wx get-label-font))]
[get-selections (entry-point (lambda () (send wx get-selections)))] [get-selections (entry-point (lambda () (send wx get-selections)))]

2
collects/mred/private/mrmenu.rkt
View File

@ -465,6 +465,6 @@
(define (menu-or-bar-parent who p) (define (menu-or-bar-parent who p)
(unless (or (is-a? p internal-menu<%>) (is-a? p menu-bar%)) (unless (or (is-a? p internal-menu<%>) (is-a? p menu-bar%))
(unless (is-a? p menu-item-container<%>) (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" (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))) "given parent" p)))

228
collects/mred/private/snipfile.rkt
View File

@ -25,126 +25,134 @@
#:lock-while-reading? [lock-while-reading? #f]) #:lock-while-reading? [lock-while-reading? #f])
;; Check arguments: ;; Check arguments:
(unless (text . is-a? . text%) (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) (check-non-negative-integer 'open-input-text-editor start)
(unless (or (eq? end 'end) (unless (or (eq? end 'end)
(and (integer? end) (exact? end) (not (negative? end)))) (and (integer? end) (exact? end) (not (negative? end))))
(raise-argument-error 'open-input-text-editor "(or/c exact-nonnegative-integer? 'end)" end)) (raise-argument-error 'open-input-text-editor "(or/c exact-nonnegative-integer? 'end)" end))
(let ([last (send text last-position)]) (let ([last (send text last-position)])
(when (start . > . last) (when (start . > . last)
(raise-range-error 'open-input-text-editor "editor" "starting " (raise-range-error 'open-input-text-editor "editor" "starting "
start text 0 last #f)) start text 0 last #f))
(unless (eq? end 'end) (unless (eq? end 'end)
(unless (<= start end last) (unless (<= start end last)
(raise-range-error 'open-input-text-editor "editor" "ending " (raise-range-error 'open-input-text-editor "editor" "ending "
end text start last 0)))) end text start last 0))))
(let ([end (if (eq? end 'end) (send text last-position) end)] (let ([end (if (eq? end 'end) (send text last-position) end)]
[snip (send text find-snip start 'after-or-none)]) [snip (send text find-snip start 'after-or-none)])
;; If the region is small enough, and if the editor contains ;; If the region is small enough, and if the editor contains
;; only string snips, then it's probably better to move ;; only string snips, then it's probably better to move
;; all of the text into a string port: ;; all of the text into a string port:
(if (or (not snip) (if (or (not snip)
(and (is-a? snip wx:string-snip%) (and (is-a? snip wx:string-snip%)
(let ([s (send text find-next-non-string-snip snip)]) (let ([s (send text find-next-non-string-snip snip)])
(or (not s) (or (not s)
((send text get-snip-position s) . >= . end))))) ((send text get-snip-position s) . >= . end)))))
(if (or expect-to-read-all? (if (or expect-to-read-all?
((- end start) . < . 4096)) ((- end start) . < . 4096))
;; It's all text, and it's short enough: just read it into a string ;; 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) (open-input-string (send text get-text start end) port-name)
;; It's all text, so the reading process is simple: ;; It's all text, so the reading process is simple:
(let ([start start]) (let ([start start])
(when lock-while-reading? (when lock-while-reading?
(send text begin-edit-sequence) (send text begin-edit-sequence)
(send text lock #t)) (send text lock #t))
(let-values ([(pipe-r pipe-w) (make-pipe)]) (let-values ([(pipe-r pipe-w) (make-pipe)])
(make-input-port/read-to-peek (make-input-port/read-to-peek
port-name port-name
(lambda (s) (lambda (s)
(let ([v (read-bytes-avail!* s pipe-r)]) (let ([v (read-bytes-avail!* s pipe-r)])
(if (eq? v 0) (if (eq? v 0)
(let ([n (min 4096 (- end start))]) (let ([n (min 4096 (- end start))])
(if (zero? n) (if (zero? n)
(begin (begin
(close-output-port pipe-w) (close-output-port pipe-w)
(when lock-while-reading? (when lock-while-reading?
(set! lock-while-reading? #f) (set! lock-while-reading? #f)
(send text lock #f) (send text lock #f)
(send text end-edit-sequence)) (send text end-edit-sequence))
eof) eof)
(begin (begin
(write-string (send text get-text start (+ start n)) pipe-w) (write-string (send text get-text start (+ start n)) pipe-w)
(set! start (+ start n)) (set! start (+ start n))
(let ([ans (read-bytes-avail!* s pipe-r)]) (let ([ans (read-bytes-avail!* s pipe-r)])
(when lock-while-reading? (when lock-while-reading?
(when (eof-object? ans) (when (eof-object? ans)
(set! lock-while-reading? #f) (set! lock-while-reading? #f)
(send text lock #f) (send text lock #f)
(send text edit-edit-sequence))) (send text edit-edit-sequence)))
ans)))) ans))))
v))) v)))
(lambda (s skip general-peek) (lambda (s skip general-peek)
(let ([v (peek-bytes-avail!* s skip #f pipe-r)]) (let ([v (peek-bytes-avail!* s skip #f pipe-r)])
(if (eq? v 0) (if (eq? v 0)
(general-peek s skip) (general-peek s skip)
v))) v)))
void)))) void))))
;; General case, which handles non-text context: ;; General case, which handles non-text context:
(with-method ([gsp (text get-snip-position)] (with-method ([gsp (text get-snip-position)]
[grn (text get-revision-number)]) [grn (text get-revision-number)]
(let-values ([(pipe-r pipe-w) (make-pipe)]) [fs (text find-snip)])
(let* ([get-text-generic (generic wx:snip% get-text)] (let-values ([(pipe-r pipe-w) (make-pipe)])
[get-count-generic (generic wx:snip% get-count)] (let* ([get-text-generic (generic wx:snip% get-text)]
[next-generic (generic wx:snip% next)] [get-count-generic (generic wx:snip% get-count)]
[revision (grn)] [next-generic (generic wx:snip% next)]
[next? #f] [revision (grn)]
[update-str-to-snip [next? #f]
(lambda (to-str) [snip-end-position (+ (gsp snip) (send-generic snip get-count-generic))]
(if snip [update-str-to-snip
(let ([snip-start (gsp snip)]) (lambda (skip to-str)
(cond (if snip
[(snip-start . >= . end) (let ([snip-start (gsp snip)])
(set! snip #f) (cond
(set! next? #f) [(snip-start . >= . end)
0] (set! snip #f)
[(is-a? snip wx:string-snip%) (set! next? #f)
(set! next? #t) 0]
(let ([c (min (send-generic snip get-count-generic) (- end snip-start))]) [(is-a? snip wx:string-snip%)
(write-string (send-generic snip get-text-generic 0 c) pipe-w) (set! next? #t)
(read-bytes-avail!* to-str pipe-r))] (let ([c (min (- (send-generic snip get-count-generic) skip)
[else (- end snip-start))])
(set! next? #f) (write-string (send-generic snip get-text-generic skip c) pipe-w)
0])) (read-bytes-avail!* to-str pipe-r))]
(begin [else
(set! next? #f) (set! next? #f)
0)))] 0]))
[next-snip (begin
(lambda (to-str) (set! next? #f)
(unless (= revision (grn)) 0)))]
(raise-arguments-error [next-snip
'text-input-port (lambda (to-str)
"editor has changed since port was opened" (cond
"editor" text)) [(= revision (grn))
(set! snip (send-generic snip next-generic)) (set! snip (send-generic snip next-generic))
(update-str-to-snip to-str))] (set! snip-end-position (and snip (+ (gsp snip) (send-generic snip get-count-generic))))
[read-chars (lambda (to-str) (update-str-to-snip 0 to-str)]
(cond [else
[next? (set! revision (grn))
(next-snip to-str)] (define old-snip-end-position snip-end-position)
[snip (set! snip (fs snip-end-position 'after-or-none))
(let ([the-snip (snip-filter snip)]) (define snip-start-position (and snip (gsp snip)))
(next-snip empty-string) (set! snip-end-position (and snip (+ snip-start-position (send-generic snip get-count-generic))))
(lambda (file line col ppos) (update-str-to-snip (if snip (- old-snip-end-position snip-start-position) 0) to-str)]))]
(if (is-a? the-snip wx:snip%) [read-chars (lambda (to-str)
(if (is-a? the-snip wx:readable-snip<%>) (cond
(send the-snip read-special file line col ppos) [next?
(send the-snip copy)) (next-snip to-str)]
the-snip)))] [snip
[else eof]))] (let ([the-snip (snip-filter snip)])
[close (lambda () (void))] (next-snip empty-string)
[port (make-input-port/read-to-peek (lambda (file line col ppos)
port-name (if (is-a? the-snip wx:snip%)
(lambda (s) (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)] (let* ([v (read-bytes-avail!* s pipe-r)]
[res (if (eq? v 0) (read-chars s) v)]) [res (if (eq? v 0) (read-chars s) v)])
(when (eof-object? res) (when (eof-object? res)
@ -154,25 +162,25 @@
(send text end-edit-sequence))) (send text end-edit-sequence)))
res)) res))
(lambda (s skip general-peek) (lambda (s skip general-peek)
(let ([v (peek-bytes-avail!* s skip #f pipe-r)]) (let ([v (peek-bytes-avail!* s skip #f pipe-r)])
(if (eq? v 0) (if (eq? v 0)
(general-peek s skip) (general-peek s skip)
v))) v)))
close)]) close)])
(when lock-while-reading? (when lock-while-reading?
(send text begin-edit-sequence) (send text begin-edit-sequence)
(send text lock #t)) (send text lock #t))
(if (is-a? snip wx:string-snip%) (if (is-a? snip wx:string-snip%)
;; Special handling for initial snip string in ;; Special handling for initial snip string in
;; case it starts too early: ;; case it starts too early:
(let* ([snip-start (gsp snip)] (let* ([snip-start (gsp snip)]
[skip (- start snip-start)] [skip (- start snip-start)]
[c (min (- (send-generic snip get-count-generic) skip) [c (min (- (send-generic snip get-count-generic) skip)
(- end snip-start))]) (- end snip-start))])
(set! next? #t) (set! next? #t)
(display (send-generic snip get-text-generic skip c) pipe-w)) (display (send-generic snip get-text-generic skip c) pipe-w))
(update-str-to-snip empty-string)) (update-str-to-snip 0 empty-string))
port))))))) port)))))))
(define (jump-to-submodule in-port expected-module k) (define (jump-to-submodule in-port expected-module k)
(let ([header (bytes-append #"^#~" (let ([header (bytes-append #"^#~"

2
collects/mred/private/wx/cocoa/choice.rkt
View File

@ -68,6 +68,8 @@
(tellv (get-cocoa) (tellv (get-cocoa)
insertItemWithTitle: #:type _NSString lbl insertItemWithTitle: #:type _NSString lbl
atIndex: #:type _NSInteger (number))) atIndex: #:type _NSInteger (number)))
(define/public (delete i)
(tellv (get-cocoa) removeItemAtIndex: #:type _NSInteger i))
(define/override (maybe-register-as-child parent on?) (define/override (maybe-register-as-child parent on?)
(register-as-child parent on?))) (register-as-child parent on?)))

1
collects/mred/private/wx/cocoa/platform.rkt
View File

@ -63,6 +63,7 @@
display-origin display-origin
display-count display-count
flush-display flush-display
get-current-mouse-state
fill-private-color fill-private-color
cancel-quit cancel-quit
get-control-font-face get-control-font-face

31
collects/mred/private/wx/cocoa/procs.rkt
View File

@ -6,6 +6,7 @@
ffi/unsafe ffi/unsafe
ffi/unsafe/objc ffi/unsafe/objc
"utils.rkt" "utils.rkt"
"const.rkt"
"types.rkt" "types.rkt"
"frame.rkt" "frame.rkt"
"window.rkt" "window.rkt"
@ -63,9 +64,10 @@
file-creator-and-type file-creator-and-type
file-selector file-selector
key-symbol-to-menu-key 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) (define (find-graphical-system-path what)
#f) #f)
@ -192,3 +194,28 @@
(define (needs-grow-box-spacer?) (define (needs-grow-box-spacer?)
(not (version-10.7-or-later?))) (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))))

21
collects/mred/private/wx/cocoa/window.rkt
View File

@ -604,6 +604,10 @@
(- y (client-y-offset)))))) (- y (client-y-offset))))))
(define/public (client-y-offset) 0) (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 (is-view?) #t)
(define/public (window-point-to-view pos) (define/public (window-point-to-view pos)
(let ([pos (if (is-view?) (let ([pos (if (is-view?)
@ -611,8 +615,17 @@
convertPoint: #:type _NSPoint pos convertPoint: #:type _NSPoint pos
fromView: #f) fromView: #f)
pos)]) pos)])
(values (NSPoint-x pos) (define x (NSPoint-x pos))
(flip-client (NSPoint-y 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) (define/public (get-x)
(->long (NSPoint-x (NSRect-origin (get-frame))))) (->long (NSPoint-x (NSRect-origin (get-frame)))))
@ -799,6 +812,8 @@
(define/public (refresh-all-children) (void)) (define/public (refresh-all-children) (void))
(define/public (screen-to-client xb yb) (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) (let ([p (tell #:type _NSPoint (get-cocoa-content)
convertPoint: #:type _NSPoint convertPoint: #:type _NSPoint
(tell #:type _NSPoint (get-cocoa-window) (tell #:type _NSPoint (get-cocoa-window)
@ -810,6 +825,8 @@
(set-box! yb (inexact->exact (floor (flip-client (NSPoint-y p))))))) (set-box! yb (inexact->exact (floor (flip-client (NSPoint-y p)))))))
(define/public (client-to-screen xb yb [flip-y? #t]) (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) (let* ([p (tell #:type _NSPoint (get-cocoa-window)
convertBaseToScreen: convertBaseToScreen:
#:type _NSPoint #:type _NSPoint

19
collects/mred/private/wx/common/queue.rkt
View File

@ -438,12 +438,23 @@
(define event-dispatch-handler (make-parameter really-dispatch-event)) (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) (define (handle-event thunk e)
(call-with-continuation-prompt ; to delimit continuations (call-with-continuation-prompt ; to delimit continuations
(lambda () (lambda ()
(call-with-continuation-prompt ; to delimit search for dispatch-event-key (call-with-continuation-prompt ; to delimit search for dispatch-event-key
(lambda () (lambda ()
;; communicate the thunk to `really-dispatch-event': ;; 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)]) (let ([b (box thunk)])
;; use the event-dispatch handler: ;; use the event-dispatch handler:
(with-continuation-mark dispatch-event-key b (with-continuation-mark dispatch-event-key b
@ -452,7 +463,13 @@
;; to the original one, then do so now: ;; to the original one, then do so now:
(when (unbox b) (when (unbox b)
(set-box! b #f) (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)))) dispatch-event-prompt))))
(define yield (define yield

8
collects/mred/private/wx/gtk/choice.rkt
View File

@ -78,9 +78,12 @@
(set! ignore-clicked? #t) (set! ignore-clicked? #t)
(gtk_combo_box_set_active gtk i) (gtk_combo_box_set_active gtk i)
(set! ignore-clicked? #f))) (set! ignore-clicked? #f)))
(define/public (get-selection) (define/public (get-selection)
(gtk_combo_box_get_active gtk)) (gtk_combo_box_get_active gtk))
(define/public (number) count) (define/public (number) count)
(define/public (clear) (define/public (clear)
(atomically (atomically
(set! ignore-clicked? #t) (set! ignore-clicked? #t)
@ -88,6 +91,7 @@
(gtk_combo_box_remove_text gtk 0)) (gtk_combo_box_remove_text gtk 0))
(set! count 0) (set! count 0)
(set! ignore-clicked? #f))) (set! ignore-clicked? #f)))
(public [-append append]) (public [-append append])
(define (-append l) (define (-append l)
(atomically (atomically
@ -96,5 +100,7 @@
(gtk_combo_box_append_text gtk l) (gtk_combo_box_append_text gtk l)
(when (= count 1) (when (= count 1)
(set-selection 0)) (set-selection 0))
(set! ignore-clicked? #f)))) (set! ignore-clicked? #f)))
(define/public (delete i)
(gtk_combo_box_remove_text gtk i)))

35
collects/mred/private/wx/gtk/frame.rkt
View File

@ -22,7 +22,8 @@
display-origin display-origin
display-size display-size
display-count 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-gtk gtk_window_resize (_fun _GtkWidget _int _int -> _void))
(define-gdk gdk_window_set_cursor (_fun _GdkWindow _pointer -> _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_iconify (_fun _GtkWindow -> _void))
(define-gtk gtk_window_deiconify (_fun _GtkWindow -> _void)) (define-gtk gtk_window_deiconify (_fun _GtkWindow -> _void))
@ -169,7 +177,7 @@
(values vbox-gtk panel-gtk)))) (values vbox-gtk panel-gtk))))
(gtk_widget_show vbox-gtk) (gtk_widget_show vbox-gtk)
(gtk_widget_show panel-gtk) (gtk_widget_show panel-gtk)
(connect-key-and-mouse gtk) (connect-enter-and-leave gtk)
(unless is-dialog? (unless is-dialog?
(gtk_window_set_icon_list gtk (cdr (force icon-pixbufs+glist)))) (gtk_window_set_icon_list gtk (cdr (force icon-pixbufs+glist))))
@ -424,7 +432,7 @@
(define/override (call-pre-on-char w e) (define/override (call-pre-on-char w e)
(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) (gtk_window_set_gravity gtk GDK_GRAVITY_STATIC)
(let-values ([(dx dy) (gtk_window_get_position gtk)] (let-values ([(dx dy) (gtk_window_get_position gtk)]
[(cdx cdy) (get-client-delta)]) [(cdx cdy) (get-client-delta)])
@ -543,3 +551,24 @@
[fh (send f get-height)]) [fh (send f get-height)])
(<= fy y (+ fy fh))) (<= fy y (+ fy fh)))
f)))) 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))))

1
collects/mred/private/wx/gtk/platform.rkt
View File

@ -64,6 +64,7 @@
display-origin display-origin
display-count display-count
flush-display flush-display
get-current-mouse-state
fill-private-color fill-private-color
cancel-quit cancel-quit
get-control-font-face get-control-font-face

22
collects/mred/private/wx/gtk/types.rkt
View File

@ -8,8 +8,8 @@
_GdkScreen _GdkScreen
_gpointer _gpointer
_GType _GType
_GdkEventType _GdkEventType
_GdkAtom _GdkAtom
_fnpointer _fnpointer
_gboolean _gboolean
@ -31,9 +31,9 @@
(struct-out GdkEventExpose) (struct-out GdkEventExpose)
_GdkEventFocus _GdkEventFocus-pointer _GdkEventFocus _GdkEventFocus-pointer
(struct-out GdkEventFocus) (struct-out GdkEventFocus)
_GdkEventSelection _GdkEventSelection-pointer _GdkEventSelection _GdkEventSelection-pointer
(struct-out GdkEventSelection) (struct-out GdkEventSelection)
_GdkRectangle _GdkRectangle-pointer _GdkRectangle _GdkRectangle-pointer
(struct-out GdkRectangle) (struct-out GdkRectangle)
_GdkColor _GdkColor-pointer _GdkColor _GdkColor-pointer
(struct-out GdkColor))) (struct-out GdkColor)))
@ -135,11 +135,11 @@
(define-cstruct _GdkEventSelection ([type _GdkEventType] (define-cstruct _GdkEventSelection ([type _GdkEventType]
[window _GdkWindow] [window _GdkWindow]
[send_event _byte] [send_event _byte]
[selection _GdkAtom] [selection _GdkAtom]
[target _GdkAtom] [target _GdkAtom]
[property _GdkAtom] [property _GdkAtom]
[time _uint32] [time _uint32]
[requestor _pointer])) [requestor _pointer]))
(define-cstruct _GdkRectangle ([x _int] (define-cstruct _GdkRectangle ([x _int]
[y _int] [y _int]
@ -155,8 +155,8 @@
(define-cstruct _GdkEventFocus ([type _GdkEventType] (define-cstruct _GdkEventFocus ([type _GdkEventType]
[window _GdkWindow] [window _GdkWindow]
[send_event _byte] [send_event _byte]
[in _short])) [in _short]))
(define-cstruct _GdkColor ([pixel _uint32] (define-cstruct _GdkColor ([pixel _uint32]
[red _uint16] [red _uint16]

351
collects/mred/private/wx/gtk/window.rkt
View File

@ -1,7 +1,7 @@
#lang racket/base #lang racket/base
(require ffi/unsafe (require ffi/unsafe
racket/class racket/class
net/uri-codec net/uri-codec
ffi/unsafe/atomic ffi/unsafe/atomic
"../../syntax.rkt" "../../syntax.rkt"
"../../lock.rkt" "../../lock.rkt"
@ -18,7 +18,7 @@
"const.rkt" "const.rkt"
"types.rkt" "types.rkt"
"widget.rkt" "widget.rkt"
"clipboard.rkt") "clipboard.rkt")
(provide (provide
(protect-out window% (protect-out window%
@ -35,6 +35,7 @@
connect-focus connect-focus
connect-key-and-mouse connect-key-and-mouse
connect-enter-and-leave
do-button-event do-button-event
(struct-out GtkRequisition) _GtkRequisition-pointer (struct-out GtkRequisition) _GtkRequisition-pointer
@ -53,9 +54,9 @@
request-flush-delay request-flush-delay
cancel-flush-delay cancel-flush-delay
win-box-valid? win-box-valid?
window->win-box window->win-box
unrealize-win-box) unrealize-win-box)
gtk->wx gtk->wx
gtk_widget_show gtk_widget_show
gtk_widget_hide) gtk_widget_hide)
@ -91,15 +92,15 @@
(define the-accelerator-group (gtk_accel_group_new)) (define the-accelerator-group (gtk_accel_group_new))
(define-cstruct _GtkWidgetT ([obj _GtkObject] (define-cstruct _GtkWidgetT ([obj _GtkObject]
[private_flags _uint16] [private_flags _uint16]
[state _byte] [state _byte]
[saved_state _byte] [saved_state _byte]
[name _pointer] [name _pointer]
[style _pointer] [style _pointer]
[req _GtkRequisition] [req _GtkRequisition]
[alloc _GtkAllocation] [alloc _GtkAllocation]
[window _GdkWindow] [window _GdkWindow]
[parent _GtkWidget])) [parent _GtkWidget]))
(define (widget-window gtk) (define (widget-window gtk)
(GtkWidgetT-window (cast gtk _GtkWidget _GtkWidgetT-pointer))) (GtkWidgetT-window (cast gtk _GtkWidget _GtkWidgetT-pointer)))
@ -122,20 +123,20 @@
(lambda (gtk context x y data info time) (lambda (gtk context x y data info time)
(let ([wx (gtk->wx gtk)]) (let ([wx (gtk->wx gtk)])
(when wx (when wx
(let ([bstr (scheme_make_sized_byte_string (let ([bstr (scheme_make_sized_byte_string
(gtk_selection_data_get_data data) (gtk_selection_data_get_data data)
(gtk_selection_data_get_length data) (gtk_selection_data_get_length data)
1)]) 1)])
(cond (cond
[(regexp-match #rx#"^file://(.*)\r\n$" bstr) [(regexp-match #rx#"^file://(.*)\r\n$" bstr)
=> (lambda (m) => (lambda (m)
(queue-window-event wx (queue-window-event wx
(lambda () (lambda ()
(let ([path (let ([path
(string->path (string->path
(uri-decode (uri-decode
(bytes->string/utf-8 (cadr m))))]) (bytes->string/utf-8 (cadr m))))])
(send wx on-drop-file path)))))])))))) (send wx on-drop-file path)))))]))))))
;; ---------------------------------------- ;; ----------------------------------------
@ -146,7 +147,7 @@
(when wx (when wx
(send wx focus-change #t) (send wx focus-change #t)
(when (send wx on-focus? #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))) #f)))
(define-signal-handler connect-focus-out "focus-out-event" (define-signal-handler connect-focus-out "focus-out-event"
(_fun _GtkWidget _GdkEventFocus-pointer -> _gboolean) (_fun _GtkWidget _GdkEventFocus-pointer -> _gboolean)
@ -194,72 +195,72 @@
(and (and
wx wx
(let ([im-str (if scroll? (let ([im-str (if scroll?
'none 'none
;; Result from `filter-key-event' is one of ;; Result from `filter-key-event' is one of
;; - #f => drop the event ;; - #f => drop the event
;; - 'none => no replacement; handle as usual ;; - 'none => no replacement; handle as usual
;; - a string => use as the keycode ;; - a string => use as the keycode
(send wx filter-key-event event))]) (send wx filter-key-event event))])
(when im-str (when im-str
(let* ([modifiers (if scroll? (let* ([modifiers (if scroll?
(GdkEventScroll-state event) (GdkEventScroll-state event)
(GdkEventKey-state event))] (GdkEventKey-state event))]
[bit? (lambda (m v) (positive? (bitwise-and m v)))] [bit? (lambda (m v) (positive? (bitwise-and m v)))]
[keyval->code (lambda (kv) [keyval->code (lambda (kv)
(or (or
(map-key-code kv) (map-key-code kv)
(integer->char (gdk_keyval_to_unicode kv))))] (integer->char (gdk_keyval_to_unicode kv))))]
[key-code (if scroll? [key-code (if scroll?
(let ([dir (GdkEventScroll-direction event)]) (let ([dir (GdkEventScroll-direction event)])
(cond (cond
[(= dir GDK_SCROLL_UP) 'wheel-up] [(= dir GDK_SCROLL_UP) 'wheel-up]
[(= dir GDK_SCROLL_DOWN) 'wheel-down] [(= dir GDK_SCROLL_DOWN) 'wheel-down]
[(= dir GDK_SCROLL_LEFT) 'wheel-left] [(= dir GDK_SCROLL_LEFT) 'wheel-left]
[(= dir GDK_SCROLL_RIGHT) 'wheel-right])) [(= dir GDK_SCROLL_RIGHT) 'wheel-right]))
(keyval->code (GdkEventKey-keyval event)))] (keyval->code (GdkEventKey-keyval event)))]
[k (new key-event% [k (new key-event%
[key-code (if (and (string? im-str) [key-code (if (and (string? im-str)
(= 1 (string-length im-str))) (= 1 (string-length im-str)))
(string-ref im-str 0) (string-ref im-str 0)
key-code)] key-code)]
[shift-down (bit? modifiers GDK_SHIFT_MASK)] [shift-down (bit? modifiers GDK_SHIFT_MASK)]
[control-down (bit? modifiers GDK_CONTROL_MASK)] [control-down (bit? modifiers GDK_CONTROL_MASK)]
[meta-down (bit? modifiers GDK_MOD1_MASK)] [meta-down (bit? modifiers GDK_MOD1_MASK)]
[alt-down (bit? modifiers GDK_META_MASK)] [alt-down (bit? modifiers GDK_META_MASK)]
[x 0] [x 0]
[y 0] [y 0]
[time-stamp (if scroll? [time-stamp (if scroll?
(GdkEventScroll-time event) (GdkEventScroll-time event)
(GdkEventKey-time event))] (GdkEventKey-time event))]
[caps-down (bit? modifiers GDK_LOCK_MASK)])]) [caps-down (bit? modifiers GDK_LOCK_MASK)])])
(when (or (and (not scroll?) (when (or (and (not scroll?)
(let-values ([(s ag sag cl) (get-alts event)] (let-values ([(s ag sag cl) (get-alts event)]
[(keyval->code*) (lambda (v) [(keyval->code*) (lambda (v)
(and v (and v
(let ([c (keyval->code v)]) (let ([c (keyval->code v)])
(and (not (equal? #\u0000 c)) (and (not (equal? #\u0000 c))
c))))]) c))))])
(let ([s (keyval->code* s)] (let ([s (keyval->code* s)]
[ag (keyval->code* ag)] [ag (keyval->code* ag)]
[sag (keyval->code* sag)] [sag (keyval->code* sag)]
[cl (keyval->code* cl)]) [cl (keyval->code* cl)])
(when s (send k set-other-shift-key-code s)) (when s (send k set-other-shift-key-code s))
(when ag (send k set-other-altgr-key-code ag)) (when ag (send k set-other-altgr-key-code ag))
(when sag (send k set-other-shift-altgr-key-code sag)) (when sag (send k set-other-shift-altgr-key-code sag))
(when cl (send k set-other-caps-key-code cl)) (when cl (send k set-other-caps-key-code cl))
(or s ag sag cl)))) (or s ag sag cl))))
(not (equal? #\u0000 key-code))) (not (equal? #\u0000 key-code)))
(unless (or scroll? down?) (unless (or scroll? down?)
;; swap altenate with main ;; swap altenate with main
(send k set-key-release-code (send k get-key-code)) (send k set-key-release-code (send k get-key-code))
(send k set-key-code 'release)) (send k set-key-code 'release))
(if (send wx handles-events? gtk) (if (send wx handles-events? gtk)
(begin (begin
(queue-window-event wx (lambda () (send wx dispatch-on-char k #f))) (queue-window-event wx (lambda () (send wx dispatch-on-char k #f)))
#t) #t)
(constrained-reply (send wx get-eventspace) (constrained-reply (send wx get-eventspace)
(lambda () (send wx dispatch-on-char k #t)) (lambda () (send wx dispatch-on-char k #t))
#t))))))))) #t)))))))))
(define-signal-handler connect-button-press "button-press-event" (define-signal-handler connect-button-press "button-press-event"
(_fun _GtkWidget _GdkEventButton-pointer -> _gboolean) (_fun _GtkWidget _GdkEventButton-pointer -> _gboolean)
@ -293,6 +294,10 @@
(let ([wx (gtk->wx gtk)]) (when wx (send wx leave-window))) (let ([wx (gtk->wx gtk)]) (when wx (send wx leave-window)))
(do-button-event gtk event #f #t))) (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]) (define (connect-key-and-mouse gtk [skip-press? #f])
(connect-key-press gtk) (connect-key-press gtk)
(connect-key-release gtk) (connect-key-release gtk)
@ -300,8 +305,7 @@
(connect-button-press gtk) (connect-button-press gtk)
(unless skip-press? (connect-button-release gtk)) (unless skip-press? (connect-button-release gtk))
(connect-pointer-motion gtk) (connect-pointer-motion gtk)
(connect-enter gtk) (connect-enter-and-leave gtk))
(connect-leave gtk))
(define (do-button-event gtk event motion? crossing?) (define (do-button-event gtk event motion? crossing?)
(let ([type (if motion? (let ([type (if motion?
@ -313,11 +317,11 @@
(and (and
wx wx
(if (or (= type GDK_2BUTTON_PRESS) (if (or (= type GDK_2BUTTON_PRESS)
(= type GDK_3BUTTON_PRESS) (= type GDK_3BUTTON_PRESS)
(and (or (= type GDK_ENTER_NOTIFY) (and (or (= type GDK_ENTER_NOTIFY)
(= type GDK_LEAVE_NOTIFY)) (= type GDK_LEAVE_NOTIFY))
(send wx skip-enter-leave-events))) (send wx skip-enter-leave-events)))
#t #t
(let* ([modifiers (if motion? (let* ([modifiers (if motion?
(GdkEventMotion-state event) (GdkEventMotion-state event)
(if crossing? (if crossing?
@ -341,53 +345,57 @@
[(1) 'left-up] [(1) 'left-up]
[(3) 'right-up] [(3) 'right-up]
[else 'middle-up])])] [else 'middle-up])])]
[m (new mouse-event% [m (let-values ([(x y) (send wx
[event-type type] adjust-event-position
[left-down (case type (->long ((if motion?
[(left-down) #t] GdkEventMotion-x
[(left-up) #f] (if crossing? GdkEventCrossing-x GdkEventButton-x))
[else (bit? modifiers GDK_BUTTON1_MASK)])] event))
[middle-down (case type (->long ((if motion? GdkEventMotion-y
[(middle-down) #t] (if crossing? GdkEventCrossing-y GdkEventButton-y))
[(middle-up) #f] event)))])
[else (bit? modifiers GDK_BUTTON2_MASK)])] (new mouse-event%
[right-down (case type [event-type type]
[(right-down) #t] [left-down (case type
[(right-up) #f] [(left-down) #t]
[else (bit? modifiers GDK_BUTTON3_MASK)])] [(left-up) #f]
[x (->long ((if motion? [else (bit? modifiers GDK_BUTTON1_MASK)])]
GdkEventMotion-x [middle-down (case type
(if crossing? GdkEventCrossing-x GdkEventButton-x)) [(middle-down) #t]
event))] [(middle-up) #f]
[y (->long ((if motion? GdkEventMotion-y [else (bit? modifiers GDK_BUTTON2_MASK)])]
(if crossing? GdkEventCrossing-y GdkEventButton-y)) [right-down (case type
event))] [(right-down) #t]
[shift-down (bit? modifiers GDK_SHIFT_MASK)] [(right-up) #f]
[control-down (bit? modifiers GDK_CONTROL_MASK)] [else (bit? modifiers GDK_BUTTON3_MASK)])]
[meta-down (bit? modifiers GDK_META_MASK)] [x x]
[alt-down (bit? modifiers GDK_MOD1_MASK)] [y y]
[time-stamp ((if motion? GdkEventMotion-time [shift-down (bit? modifiers GDK_SHIFT_MASK)]
(if crossing? GdkEventCrossing-time GdkEventButton-time)) [control-down (bit? modifiers GDK_CONTROL_MASK)]
event)] [meta-down (bit? modifiers GDK_META_MASK)]
[caps-down (bit? modifiers GDK_LOCK_MASK)])]) [alt-down (bit? modifiers GDK_MOD1_MASK)]
(if (send wx handles-events? gtk) [time-stamp ((if motion? GdkEventMotion-time
(begin (if crossing? GdkEventCrossing-time GdkEventButton-time))
(queue-window-event wx (lambda () event)]
(send wx dispatch-on-event m #f))) [caps-down (bit? modifiers GDK_LOCK_MASK)]))])
#t) (if (send wx handles-events? gtk)
(constrained-reply (send wx get-eventspace) (begin
(lambda () (or (send wx dispatch-on-event m #t) (queue-window-event wx (lambda ()
(send wx internal-pre-on-event gtk m))) (send wx dispatch-on-event m #f)))
#t #t)
#:fail-result (constrained-reply (send wx get-eventspace)
;; an enter event is synthesized when a button is (lambda () (or (send wx dispatch-on-event m #t)
;; enabled and the mouse is over the button, and the (send wx internal-pre-on-event gtk m)))
;; event is not dispatched via the eventspace; leave #t
;; events are perhaps similarly synthesized, so allow #:fail-result
;; them, too ;; an enter event is synthesized when a button is
(if (or (eq? type 'enter) (eq? type 'leave)) ;; enabled and the mouse is over the button, and the
#f ;; event is not dispatched via the eventspace; leave
#t))))))))) ;; 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 drag-connected? #f)
(define/public (drag-accept-files on?) (define/public (drag-accept-files on?)
(if on? (if on?
(begin (begin
(unless drag-connected? (unless drag-connected?
(connect-drag-data-received gtk) (connect-drag-data-received gtk)
(set! drag-connected? #t)) (set! drag-connected? #t))
(gtk_drag_dest_set gtk GTK_DEST_DEFAULT_ALL GDK_ACTION_COPY) (gtk_drag_dest_set gtk GTK_DEST_DEFAULT_ALL GDK_ACTION_COPY)
(gtk_drag_dest_add_uri_targets gtk)) (gtk_drag_dest_add_uri_targets gtk))
(gtk_drag_dest_unset gtk))) (gtk_drag_dest_unset gtk)))
(define/public (set-focus) (define/public (set-focus)
(gtk_widget_grab_focus (get-client-gtk))) (gtk_widget_grab_focus (get-client-gtk)))
@ -693,17 +701,34 @@
(define/public (refresh-all-children) (void)) (define/public (refresh-all-children) (void))
(define/public (screen-to-client x y) (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)] (let ([xb (box 0)]
[yb (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! x (- (unbox x) (unbox xb)))
(set-box! y (- (unbox y) (unbox yb))))) (set-box! y (- (unbox y) (unbox yb)))))
(define/public (client-to-screen x y) (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)]) (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! x (+ (unbox x) save-x dx))
(set-box! y (+ (unbox y) save-y dy)))) (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) (define/public (get-client-delta)
(values 0 0)) (values 0 0))
@ -736,7 +761,7 @@
(when win (when win
(set-mcar! win-box #f) (set-mcar! win-box #f)
(for ([i (in-range (mcdr win-box))]) (for ([i (in-range (mcdr win-box))])
(gdk_window_thaw_updates win))))) (gdk_window_thaw_updates win)))))
(define (request-flush-delay win-box) (define (request-flush-delay win-box)
(do-request-flush-delay (do-request-flush-delay
@ -744,15 +769,15 @@
(lambda (win-box) (lambda (win-box)
(let ([win (mcar win-box)]) (let ([win (mcar win-box)])
(and win (and win
;; The freeze/thaw state is actually with the window's ;; The freeze/thaw state is actually with the window's
;; implementation, so force a native implementation of the ;; implementation, so force a native implementation of the
;; window to try to avoid it changing out from underneath ;; window to try to avoid it changing out from underneath
;; us between the freeze and thaw actions. ;; us between the freeze and thaw actions.
(gdk_window_ensure_native win) (gdk_window_ensure_native win)
(begin (begin
(gdk_window_freeze_updates win) (gdk_window_freeze_updates win)
(set-mcdr! win-box (add1 (mcdr win-box))) (set-mcdr! win-box (add1 (mcdr win-box)))
#t)))) #t))))
(lambda (win-box) (lambda (win-box)
(let ([win (mcar win-box)]) (let ([win (mcar win-box)])
(when win (when win
@ -766,5 +791,5 @@
(lambda (win-box) (lambda (win-box)
(let ([win (mcar win-box)]) (let ([win (mcar win-box)])
(when win (when win
(gdk_window_thaw_updates win) (gdk_window_thaw_updates win)
(set-mcdr! win-box (sub1 (mcdr win-box))))))))) (set-mcdr! win-box (sub1 (mcdr win-box)))))))))

1
collects/mred/private/wx/platform.rkt
View File

@ -50,6 +50,7 @@
display-origin display-origin
display-count display-count
flush-display flush-display
get-current-mouse-state
fill-private-color fill-private-color
cancel-quit cancel-quit
get-control-font-face get-control-font-face

8
collects/mred/private/wx/win32/choice.rkt
View File

@ -102,13 +102,13 @@
(SendMessageW hwnd CB_RESETCONTENT 0 0) (SendMessageW hwnd CB_RESETCONTENT 0 0)
(set! num-choices 0))) (set! num-choices 0)))
(public [append* append]) (public [append* append])
(define (append* str) (define (append* str)
(atomically (atomically
(SendMessageW/str hwnd CB_ADDSTRING 0 str) (SendMessageW/str hwnd CB_ADDSTRING 0 str)
(set! num-choices (add1 num-choices)) (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)))))

1
collects/mred/private/wx/win32/const.rkt
View File

@ -617,6 +617,7 @@
(define CB_SETCURSEL #x014E) (define CB_SETCURSEL #x014E)
(define CB_GETCURSEL #x0147) (define CB_GETCURSEL #x0147)
(define CB_ADDSTRING #x0143) (define CB_ADDSTRING #x0143)
(define CB_DELETESTRING #x0144)
(define CB_RESETCONTENT #x014B) (define CB_RESETCONTENT #x014B)
(define CBN_SELENDOK 9) (define CBN_SELENDOK 9)

1
collects/mred/private/wx/win32/platform.rkt
View File

@ -64,6 +64,7 @@
display-origin display-origin
display-count display-count
flush-display flush-display
get-current-mouse-state
fill-private-color fill-private-color
cancel-quit cancel-quit
get-control-font-face get-control-font-face

24
collects/mred/private/wx/win32/procs.rkt
View File

@ -43,6 +43,7 @@
get-highlight-text-color get-highlight-text-color
check-for-break) check-for-break)
flush-display flush-display
get-current-mouse-state
fill-private-color fill-private-color
play-sound play-sound
location->window location->window
@ -116,3 +117,26 @@
(define (check-for-break) #f) (define (check-for-break) #f)
(define (needs-grow-box-spacer?) #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))))

46
collects/mred/private/wx/win32/types.rkt
View File

@ -1,13 +1,13 @@
#lang racket/base #lang racket/base
(require ffi/unsafe (require ffi/unsafe
ffi/winapi) ffi/winapi)
(provide (provide
(protect-out _wfun (protect-out _wfun
_WORD _WORD
_DWORD _DWORD
_UDWORD _UDWORD
_ATOM _ATOM
_WPARAM _WPARAM
_LPARAM _LPARAM
@ -95,35 +95,35 @@
(define _permanent-string/utf-16 (define _permanent-string/utf-16
(make-ctype _pointer (make-ctype _pointer
(lambda (s) (lambda (s)
(and s (and s
(let ([v (malloc _gcpointer)]) (let ([v (malloc _gcpointer)])
(ptr-set! v _string/utf-16 s) (ptr-set! v _string/utf-16 s)
(let ([p (ptr-ref v _gcpointer)]) (let ([p (ptr-ref v _gcpointer)])
(let ([len (+ 1 (utf-16-length s))]) (let ([len (+ 1 (utf-16-length s))])
(let ([c (malloc len _uint16 'raw)]) (let ([c (malloc len _uint16 'raw)])
(memcpy c p len _uint16) (memcpy c p len _uint16)
c)))))) c))))))
(lambda (p) p))) (lambda (p) p)))
(define _LONG _long) (define _LONG _long)
(define _ULONG _ulong) (define _ULONG _ulong)
(define _SHORT _short) (define _SHORT _short)
(define-cstruct _POINT ([x _LONG] (define-cstruct _POINT ([x _LONG]
[y _LONG])) [y _LONG]))
(define-cstruct _RECT ([left _LONG] (define-cstruct _RECT ([left _LONG]
[top _LONG] [top _LONG]
[right _LONG] [right _LONG]
[bottom _LONG])) [bottom _LONG]))
(define-cstruct _MSG ([hwnd _HWND] (define-cstruct _MSG ([hwnd _HWND]
[message _UINT] [message _UINT]
[wParam _WPARAM] [wParam _WPARAM]
[lParam _LPARAM] [lParam _LPARAM]
[time _DWORD] [time _DWORD]
[pt _POINT])) [pt _POINT]))
(define (short v) (define (short v)
(if (zero? (bitwise-and #x8000 v)) (if (zero? (bitwise-and #x8000 v))

22
collects/mred/private/wx/win32/window.rkt
View File

@ -412,12 +412,29 @@
(define/public (on-resized) (void)) (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) (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))]) (let ([p (make-POINT (unbox x) (unbox y))])
(ScreenToClient (get-client-hwnd) p) (ScreenToClient (get-client-hwnd) p)
(set-box! x (POINT-x p)) (set-box! x (POINT-x p))
(set-box! y (POINT-y p)))) (set-box! y (POINT-y p))))
(define/public (client-to-screen x y) (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))]) (let ([p (make-POINT (unbox x) (unbox y))])
(ClientToScreen (get-client-hwnd) p) (ClientToScreen (get-client-hwnd) p)
(set-box! x (POINT-x p)) (set-box! x (POINT-x p))
@ -607,6 +624,7 @@
[bit? (lambda (v b) (not (zero? (bitwise-and v b))))]) [bit? (lambda (v b) (not (zero? (bitwise-and v b))))])
(let ([make-e (let ([make-e
(lambda (type) (lambda (type)
(define-values (mx my) (adjust-event-position x y))
(new mouse-event% (new mouse-event%
[event-type type] [event-type type]
[left-down (case type [left-down (case type
@ -621,8 +639,8 @@
[(right-down) #t] [(right-down) #t]
[(right-up) #f] [(right-up) #f]
[else (bit? flags MK_RBUTTON)])] [else (bit? flags MK_RBUTTON)])]
[x x] [x mx]
[y y] [y my]
[shift-down (bit? flags MK_SHIFT)] [shift-down (bit? flags MK_SHIFT)]
[control-down (bit? flags MK_CONTROL)] [control-down (bit? flags MK_CONTROL)]
[meta-down #f] [meta-down #f]

17
collects/mred/private/wxlitem.rkt
View File

@ -59,7 +59,7 @@
(define wx-label-panel% (define wx-label-panel%
(class wx-control-horizontal-panel% (class wx-control-horizontal-panel%
(init proxy parent label style font halign valign) (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 c #f)
(define/override (enable on?) (if c (send c enable on?) (void))) (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 (set-label s) (when l (send l set-label s)))
(define/public (get-label) (and l (send l get-label))) (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 (get-p) p)
(define/public (set-c v sx? sy?) (define/public (set-c v sx? sy?)
(set! c v) (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-x sx?)
(send c stretchable-in-y sy?) (send c stretchable-in-y sy?)
(send c skip-subwindow-events? #t)))) (send c skip-subwindow-events? #t))))
@ -113,7 +125,8 @@
(get-selection) (get-selection)
(number) (number)
(clear) (clear)
(append lbl)) (append lbl)
(delete i))
(stretchable-in-y #f) (stretchable-in-y #f)
(stretchable-in-x #f))) (stretchable-in-x #f)))

1
collects/mred/private/wxpanel.rkt
View File

@ -54,6 +54,7 @@
(unless (negative? h) (set! height h)))] (unless (negative? h) (set! height h)))]
[get-x (lambda () pos-x)] [get-x (lambda () pos-x)]
[get-y (lambda () pos-y)] [get-y (lambda () pos-y)]
[set-event-positions-wrt (lambda (c) (void))]
[get-width (lambda () width)] [get-width (lambda () width)]
[get-height (lambda () height)] [get-height (lambda () height)]
[adopt-child (lambda (c) (send (get-parent) adopt-child c))]) [adopt-child (lambda (c) (send (get-parent) adopt-child c))])

95
collects/mrlib/graph.rkt
View File

@ -3,7 +3,8 @@
racket/list racket/list
racket/math racket/math
racket/gui/base racket/gui/base
(for-syntax racket/base) racket/match
(for-syntax racket/base)
racket/contract) racket/contract)
(provide graph-snip<%> (provide graph-snip<%>
@ -377,7 +378,7 @@
(let ([old-currently-overs currently-overs]) (let ([old-currently-overs currently-overs])
(set! currently-overs new-currently-overs) (set! currently-overs new-currently-overs)
(on-mouse-over-snips currently-overs) (on-mouse-over-snips currently-overs)
(for-each (for-each
(lambda (old-currently-over) (lambda (old-currently-over)
(invalidate-to-children/parents old-currently-over dc)) (invalidate-to-children/parents old-currently-over dc))
@ -386,9 +387,8 @@
(lambda (new-currently-over) (lambda (new-currently-over)
(invalidate-to-children/parents new-currently-over dc)) (invalidate-to-children/parents new-currently-over dc))
new-currently-overs)))) new-currently-overs))))
(define/public (on-mouse-over-snips snips) (define/public (on-mouse-over-snips snips) (void))
(void))
;; set-equal : (listof snip) (listof snip) -> boolean ;; set-equal : (listof snip) (listof snip) -> boolean
;; typically lists will be small (length 1), ;; typically lists will be small (length 1),
@ -401,57 +401,42 @@
;; invalidate-to-children/parents : snip dc -> void ;; invalidate-to-children/parents : snip dc -> void
;; invalidates the region containing this snip and ;; invalidates the region containing this snip and
;; all of its children and parents. ;; all of its children and parents.
(inherit invalidate-bitmap-cache)
(define/private (invalidate-to-children/parents snip dc) (define/private (invalidate-to-children/parents snip dc)
(when (is-a? snip graph-snip<%>) (when (is-a? snip graph-snip<%>)
(let* ([parents-and-children (append (get-all-parents snip) (define-values (_1 text-height _2 _3) (send dc get-text-extent "Label" #f #f 0))
(get-all-children snip))] (define parents-and-children (append (get-all-parents snip)
[rects (eliminate-redundancies (get-rectangles snip parents-and-children))] (get-all-children snip)))
[or/c (or/c-rects rects)] (define rects (get-rectangles snip parents-and-children))
[text-height (call-with-values (for ([rect (in-list rects)])
(λ () (send dc get-text-extent "Label" #f #f 0)) (save-rectangle-to-invalidate
(λ (w h a s) h))] (- (rect-left rect) text-height)
[invalidate-rect (- (rect-top rect) text-height)
(lambda (rect) (+ (rect-right rect) text-height)
(invalidate-bitmap-cache (- (rect-left rect) text-height) (+ (rect-bottom 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)]))))
;; (listof rect) -> (listof rect) (define pending-invalidate-rectangle #f)
(define/private (eliminate-redundancies rects) (define pending-invalidate-rectangle-timer #f)
(let loop ([rects rects] (inherit invalidate-bitmap-cache)
[acc null]) (define/private (run-pending-invalidate-rectangle)
(cond (define the-pending-invalidate-rectangle pending-invalidate-rectangle)
[(null? rects) acc] (set! pending-invalidate-rectangle #f)
[else (let ([r (car rects)]) (invalidate-bitmap-cache . the-pending-invalidate-rectangle))
(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))]))])))
;; rect-included-in? : rect rect -> boolean (define/private (save-rectangle-to-invalidate l t r b)
(define/private (rect-included-in? r1 r2) (unless pending-invalidate-rectangle-timer
(and ((rect-left r1) . >= . (rect-left r2)) (set! pending-invalidate-rectangle-timer
((rect-top r1) . >= . (rect-top r2)) (new timer% [notify-callback
((rect-right r1) . <= . (rect-right r2)) (λ () (run-pending-invalidate-rectangle))])))
((rect-bottom r1) . <= . (rect-bottom r2)))) (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 ;; get-rectangles : snip (listof snip) -> rect
;; computes the rectangles that need to be invalidated for connecting ;; computes the rectangles that need to be invalidated for connecting
@ -519,7 +504,11 @@
(let ([old-font (send dc get-font)]) (let ([old-font (send dc get-font)])
(when edge-label-font (when edge-label-font
(send dc set-font 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 (when edge-label-font
(send dc set-font old-font)))) (send dc set-font old-font))))
(super on-paint before? dc left top right bottom dx dy draw-caret)) (super on-paint before? dc left top right bottom dx dy draw-caret))

7
collects/mrlib/private/regmk.rkt
View File

@ -1,6 +1,9 @@
#lang racket #lang racket/base
(require (for-syntax racket/base))
(provide define-struct/reg-mk (provide define-struct/reg-mk
id->constructor id->constructor
(struct-out point) (struct-out point)
(struct-out bb)) (struct-out bb))

2
collects/mrlib/scribblings/switchable-button.scrbl
View File

@ -15,7 +15,7 @@
@defconstructor/auto-super[([label string?] @defconstructor/auto-super[([label string?]
[callback (-> (is-a?/c switchable-button%) any/c)] [callback (-> (is-a?/c switchable-button%) any/c)]
[bitmap (is-a?/c bitmap%)] [bitmap (is-a?/c bitmap%)]
[alternate-bitmap (is-a?/c bitmap%) bitmap] [alternate-bitmap (is-a?/c bitmap%) bitmap]
[vertical-tight? boolean? #f])]{ [vertical-tight? boolean? #f])]{
The @racket[callback] is called when the button The @racket[callback] is called when the button
is pressed. The @racket[string] and @racket[bitmap] are is pressed. The @racket[string] and @racket[bitmap] are

11
collects/scribblings/framework/color.scrbl
View File

@ -154,6 +154,17 @@
Sets the currently active regions to be @racket[regions]. 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?)))))]{ @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 This returns the list of regions that are currently being colored in the
editor. editor.

2
collects/scribblings/framework/splash.scrbl
View File

@ -26,7 +26,7 @@ that number to control the gauge along the bottom of the splash screen.
[splash-title string?] [splash-title string?]
[width-default exact-nonnegative-integer?] [width-default exact-nonnegative-integer?]
[#:allow-funny? allow-funny? boolean? #f] [#:allow-funny? allow-funny? boolean? #f]
[#:frame-icon [#:frame-icon
frame-icon frame-icon
(or/c #f (or/c #f
(is-a?/c bitmap%) (is-a?/c bitmap%)

53
collects/scribblings/gui/editor-intf.scrbl
View File

@ -1,5 +1,9 @@
#lang scribble/doc #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<%> ()]{ @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 If the @racket[undoable?] flag is @racket[#f], then the changes made
in the sequence cannot be reversed through the @method[editor<%> 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 @method[editor<%> begin-edit-sequence] when nested sequences are
used. Note that, for a @racket[text%] object, the character-inserting used. Note that, for a @racket[text%] object, the character-inserting
version of @method[text% insert] interferes with sequence-based undo version of @method[text% insert] interferes with sequence-based undo

10
collects/scribblings/gui/list-box-class.scrbl
View File

@ -157,16 +157,6 @@ style. The new column is logically the last column, and it is initially
displayed as the last column.} 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?]) @defmethod[(delete-column [n exact-nonnegative-integer?])
void?]{ void?]{

19
collects/scribblings/gui/list-control-intf.scrbl
View File

@ -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?]) @defmethod[(find-string [s string?])
(or/c exact-nonnegative-integer? #f)]{ (or/c exact-nonnegative-integer? #f)]{
Finds a user-selectable item matching the given string. If no matching Finds a user-selectable item matching the given string. If no matching
choice is found, @racket[#f] is returned, otherwise the index of the 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) @defmethod[(get-selection)
(or/c exact-nonnegative-integer? #f)]{ (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 from @racket[0]). If the choice item currently contains no choices or no
selections, @racket[#f] is returned. If multiple selections are selections, @racket[#f] is returned. If multiple selections are
allowed and multiple items are selected, the index of the first 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?]) @defmethod[(get-string [n exact-nonnegative-integer?])
(and/c immutable? label-string?)]{ (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 @racket[0]). If the provided index is larger than the greatest index in
the list control, @|MismatchExn|. the list control, @|MismatchExn|.
@ -81,7 +92,7 @@ Returns the currently selected item. If the control currently
@defmethod[(set-selection [n exact-nonnegative-integer?]) @defmethod[(set-selection [n exact-nonnegative-integer?])
void?]{ 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 @racket[0]). If the given index larger than the greatest index in the
list control, @|MismatchExn|. list control, @|MismatchExn|.

2
collects/scribblings/gui/menu-item-intf.scrbl
View File

@ -10,7 +10,7 @@ A @racket[menu-item<%>] object is an element within a @racket[menu%],
@racket[menu-item<%>] object. @racket[menu-item<%>] object.
A menu item is either a @racket[separator-menu-item%] object (merely 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 is more specifically an instance of either @racket[menu-item%] (a
plain menu item), @racket[checkable-menu-item%] (a checkable menu plain menu item), @racket[checkable-menu-item%] (a checkable menu
item), or @racket[menu%] (a submenu). item), or @racket[menu%] (a submenu).

9
collects/scribblings/gui/miscwin-funcs.scrbl
View File

@ -194,6 +194,15 @@ break is sent (via @racket[break-thread]) to the created eventspace's
@tech{handler thread}.} @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?]{ @defproc[(hide-cursor-until-moved) void?]{
Hides the cursor until the user moves the mouse or clicks the mouse Hides the cursor until the user moves the mouse or clicks the mouse

17
collects/scribblings/gui/win-overview.scrbl
View File

@ -951,6 +951,23 @@ Along similar lines, if a button callback captures a continuation
captured during a button callback is therefore potentially useful captured during a button callback is therefore potentially useful
outside of the same callback. 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} @section[#:tag "animation"]{Animation in Canvases}
The content of a canvas is buffered, so if a canvas must be redrawn, The content of a canvas is buffered, so if a canvas must be redrawn,

57
collects/tests/gracket/editor.rktl
View File

@ -304,6 +304,62 @@
(test #f 'peek-t (peek-byte-or-special i 0)) (test #f 'peek-t (peek-byte-or-special i 0))
(test 49 'read-1 (peek-byte-or-special i 1)))) (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 ;; ;; Snips and Streams ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -325,6 +381,7 @@
snip)) snip))
(super-instantiate ()))) (super-instantiate ())))
(define snip-class (make-object (mk-number-snip-class% #t))) (define snip-class (make-object (mk-number-snip-class% #t)))
(send snip-class set-classname (format "~s" `(lib "number-snip.ss" "drscheme" "private"))) (send snip-class set-classname (format "~s" `(lib "number-snip.ss" "drscheme" "private")))
(send (get-the-snip-class-list) add snip-class) (send (get-the-snip-class-list) add snip-class)

38
collects/tests/gracket/item.rkt
View File

@ -1556,13 +1556,11 @@
(when (<= 0 p (sub1 (length actual-content))) (when (<= 0 p (sub1 (length actual-content)))
(set! actual-content (gone actual-content p)) (set! actual-content (gone actual-content p))
(set! actual-user-data (gone actual-user-data p)))) (set! actual-user-data (gone actual-user-data p))))
(define db (if list? (define db (make-object button%
(make-object button% "Delete" cdp
"Delete" cdp (lambda (b e)
(lambda (b e) (let ([p (send c get-selection)])
(let ([p (send c get-selection)]) (delete p)))))
(delete p))))
null))
(define dab (if list? (define dab (if list?
(make-object button% (make-object button%
"Delete Above" cdp "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)) '(arrow bullseye cross hand ibeam watch blank size-n/s size-e/w size-ne/sw size-nw/se))
(send f show #t)) (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 vertical-pane% crp) ; filler
(make-object button% "Cursors" crp (lambda (b e) (cursors))) (make-object button% "Cursors" crp (lambda (b e) (cursors)))
(make-object vertical-pane% crp) ; filler (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))) (make-object button% "Make Radiobox Frame" crp (lambda (b e) (radiobox-frame)))
(define cp (make-object horizontal-pane% ap)) (define cp (make-object horizontal-pane% ap))
(send cp stretchable-width #f) (send cp stretchable-width #f)

319
collects/tests/gracket/mem.rkt
View File

@ -21,8 +21,8 @@
(define allocated '()) (define allocated '())
(define (remember tag v) (define (remember tag v)
(set! allocated (set! allocated
(cons (cons tag (make-weak-box v)) (cons (cons tag (make-weak-box v))
allocated)) allocated))
v) v)
(define sub-collect-frame (define sub-collect-frame
@ -71,163 +71,163 @@
(unless (zero? n) (unless (zero? n)
(let ([tag (cons id n)]) (let ([tag (cons id n)])
(let* ([edit (remember tag (make-object text%))] (let* ([edit (remember tag (make-object text%))]
[ef (let ([f (make-object frame% "Editor Frame")]) [ef (let ([f (make-object frame% "Editor Frame")])
(send (make-object editor-canvas% f) set-editor edit) (send (make-object editor-canvas% f) set-editor edit)
(remember tag f))] (remember tag f))]
[c (make-custodian)] [c (make-custodian)]
[es (parameterize ([current-custodian c]) [es (parameterize ([current-custodian c])
(make-eventspace))]) (make-eventspace))])
(when edit? (when edit?
(send ef show #t) (send ef show #t)
(sleep 0.1)) (sleep 0.1))
(parameterize ([current-eventspace es]) (parameterize ([current-eventspace es])
(send (remember (send (remember
tag tag
(make-object (make-object
(class timer% (class timer%
(init-rest args) (init-rest args)
(override* [notify (lambda () (void))]) (override* [notify (lambda () (void))])
(apply super-make-object args)))) (apply super-make-object args))))
start 100)) start 100))
(when frame? (when frame?
(let* ([f (remember tag (let* ([f (remember tag
(make-object (if (even? n) (make-object (if (even? n)
frame% frame%
dialog%) dialog%)
"Tester" #f 200 200))] "Tester" #f 200 200))]
[cb (lambda (x y) f)] [cb (lambda (x y) f)]
[p (remember tag (make-object (get-pane% n) f))]) [p (remember tag (make-object (get-pane% n) f))])
(remember tag (make-object canvas% f)) (remember tag (make-object canvas% f))
(when (zero? (modulo n 3)) (when (zero? (modulo n 3))
(thread (lambda () (send f show #t))) (thread (lambda () (send f show #t)))
(let loop () (sleep) (unless (send f is-shown?) (loop)))) (let loop () (sleep) (unless (send f is-shown?) (loop))))
(remember tag (make-object button% "one" p cb)) (remember tag (make-object button% "one" p cb))
(let ([class check-box%]) (let ([class check-box%])
(let loop ([m 10]) (let loop ([m 10])
(unless (zero? m) (unless (zero? m)
(remember (cons tag m) (remember (cons tag m)
(make-object class "another" p cb)) (make-object class "another" p cb))
(loop (sub1 m))))) (loop (sub1 m)))))
(remember tag (make-object check-box% "check" p cb)) (remember tag (make-object check-box% "check" p cb))
(remember tag (make-object choice% "choice" '("a" "b" "c") p cb)) (remember tag (make-object choice% "choice" '("a" "b" "c") p cb))
(remember tag (make-object list-box% "list" '("apple" "banana" "coconut") (remember tag (make-object list-box% "list" '("apple" "banana" "coconut")
p cb)) p cb))
(remember tag (make-object button% "two" p cb)) (remember tag (make-object button% "two" p cb))
(send f show #f))) (send f show #f)))
(when subwindows? (when subwindows?
(let ([p (make-object (get-panel% n) sub-collect-frame)] (let ([p (make-object (get-panel% n) sub-collect-frame)]
[cv (make-object canvas% sub-collect-frame)] [cv (make-object canvas% sub-collect-frame)]
[add-objects [add-objects
(lambda (p tag hide?) (lambda (p tag hide?)
(let ([b (let* ([x #f] (let ([b (let* ([x #f]
[bcb (lambda (a b) x)]) [bcb (lambda (a b) x)])
(set! x (make-object button% "one" p bcb)) (set! x (make-object button% "one" p bcb))
x)] x)]
[c (make-object check-box% "check" p void)] [c (make-object check-box% "check" p void)]
[co (make-object choice% "choice" '("a" "b" "c") p void)] [co (make-object choice% "choice" '("a" "b" "c") p void)]
[cv (make-object canvas% p)] [cv (make-object canvas% p)]
[lb (make-object list-box% "list" '("apple" "banana" "coconut") p void)]) [lb (make-object list-box% "list" '("apple" "banana" "coconut") p void)])
(when hide? (when hide?
(send p delete-child b) (send p delete-child b)
(send p delete-child c) (send p delete-child c)
(send p delete-child cv) (send p delete-child cv)
(send p delete-child co) (send p delete-child co)
(send p delete-child lb)) (send p delete-child lb))
(remember tag b) (remember tag b)
(remember tag c) (remember tag c)
(remember tag cv) (remember tag cv)
(remember tag co) (remember tag co)
(remember tag lb)))]) (remember tag lb)))])
(add-objects sub-collect-panel (cons 'sc1 tag) #t) (add-objects sub-collect-panel (cons 'sc1 tag) #t)
(add-objects p (cons 'sc2 tag) #f) (add-objects p (cons 'sc2 tag) #f)
(remember (cons 'sc0 tag) p) (remember (cons 'sc0 tag) p)
(remember (cons 'sc0 tag) cv) (remember (cons 'sc0 tag) cv)
(send sub-collect-frame delete-child p) (send sub-collect-frame delete-child p)
(send sub-collect-frame delete-child cv))) (send sub-collect-frame delete-child cv)))
(when (and edit? insert?) (when (and edit? insert?)
(let ([e edit]) (let ([e edit])
(send e begin-edit-sequence) (send e begin-edit-sequence)
(when load-file? (when load-file?
(send e load-file (build-path source-dir "mem.rkt"))) (send e load-file (build-path source-dir "mem.rkt")))
(let loop ([i 20]) (let loop ([i 20])
(send e insert (number->string i)) (send e insert (number->string i))
(unless (zero? i) (unless (zero? i)
(loop (sub1 i)))) (loop (sub1 i))))
(let ([s (make-object editor-snip%)]) (let ([s (make-object editor-snip%)])
(send (send s get-editor) insert "Hello!") (send (send s get-editor) insert "Hello!")
(send e insert s)) (send e insert s))
(send e insert #\newline) (send e insert #\newline)
(send e insert "done") (send e insert "done")
(send e set-modified #f) (send e set-modified #f)
(send e end-edit-sequence))) (send e end-edit-sequence)))
(when menus? (when menus?
(let ([f (remember tag (make-object frame% "MB Frame 0"))]) (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))))) (remember tag (make-object menu% "TM1" (remember (cons 'q tag) (make-object menu-bar% f)))))
(let* ([mb (remember tag (make-object menu-bar% ef))] (let* ([mb (remember tag (make-object menu-bar% ef))]
[m (remember tag (make-object menu% "Ok" mb))]) [m (remember tag (make-object menu% "Ok" mb))])
(remember tag (make-object menu-item% "Hi" m void)) (remember tag (make-object menu-item% "Hi" m void))
(remember tag (make-object menu-item% "There" m void #\t)) (remember tag (make-object menu-item% "There" m void #\t))
(remember tag (remember tag
(make-object checkable-menu-item% (make-object checkable-menu-item%
"Checkable" "Checkable"
(remember tag (make-object menu% "Hello" m)) (remember tag (make-object menu% "Hello" m))
void)) void))
(let ([i (remember tag (make-object menu-item% "Delete Me" m void))]) (let ([i (remember tag (make-object menu-item% "Delete Me" m void))])
(send i delete))) (send i delete)))
(when subwindows? (when subwindows?
(unless permanent-ready? (unless permanent-ready?
(semaphore-wait mb-lock) (semaphore-wait mb-lock)
(unless (send sub-collect-frame get-menu-bar) (unless (send sub-collect-frame get-menu-bar)
(let ([mb (make-object menu-bar% sub-collect-frame)]) (let ([mb (make-object menu-bar% sub-collect-frame)])
(make-object menu% "Permanent" mb))) (make-object menu% "Permanent" mb)))
(set! permanent-ready? #t) (set! permanent-ready? #t)
(semaphore-post mb-lock)) (semaphore-post mb-lock))
(let* ([mb (send sub-collect-frame get-menu-bar)] (let* ([mb (send sub-collect-frame get-menu-bar)]
[mm (car (send mb get-items))]) [mm (car (send mb get-items))])
(send (remember (cons 'm tag) (make-object menu-item% "Delete Me" mm void)) delete) (send (remember (cons 'm tag) (make-object menu-item% "Delete Me" mm void)) delete)
(let ([m (remember tag (make-object menu% "Temporary" mb))]) (let ([m (remember tag (make-object menu% "Temporary" mb))])
(remember (cons 't tag) (make-object menu-item% "Temp Hi" m void)) (remember (cons 't tag) (make-object menu-item% "Temp Hi" m void))
(send m delete))))) (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)
(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) (define (still)
(map (lambda (x) (map (lambda (x)
(let ([v (weak-box-value (cdr x))]) (let ([v (weak-box-value (cdr x))])
(when v (when v
(printf "~s ~s\n" (car x) v)))) (printf "~s ~s\n" (car x) v))))
allocated) allocated)
(void)) (void))
@ -241,29 +241,29 @@
(define (breakable t) (define (breakable t)
(if #f (if #f
(thread (lambda () (thread (lambda ()
(read) (read)
(printf "breaking\n") (printf "breaking\n")
(break-thread t) (break-thread t)
(thread-wait t) (thread-wait t)
(printf "done\n"))) (printf "done\n")))
(void))) (void)))
(define (do-test) (define (do-test)
(let ([sema (make-semaphore)]) (let ([sema (make-semaphore)])
(let loop ([n num-threads]) (let loop ([n num-threads])
(unless (zero? n) (unless (zero? n)
(breakable (breakable
(thread (lambda () (thread (lambda ()
(stw (current-thread) n) (stw (current-thread) n)
(dynamic-wind (dynamic-wind
void void
(lambda () (maker n num-times)) (lambda () (maker n num-times))
(lambda () (semaphore-post sema)))))) (lambda () (semaphore-post sema))))))
(loop (sub1 n)))) (loop (sub1 n))))
(let loop ([n num-threads]) (let loop ([n num-threads])
(unless (zero? n) (unless (zero? n)
(yield sema) (yield sema)
(loop (sub1 n))))) (loop (sub1 n)))))
(collect-garbage) (collect-garbage)
(collect-garbage) (collect-garbage)
@ -280,4 +280,3 @@
(still))) (still)))
(do-test) (do-test)

119
collects/tests/utils/gui.rkt
View File

@ -1,8 +1,10 @@
(module gui mzscheme #lang racket/base
(require mred
mzlib/class (require racket/gui/base
mzlib/etc) racket/class)
(provide find-labelled-window whitespace-string=?) (provide find-labelled-window
find-labelled-windows
whitespace-string=?)
;; whitespace-string=? : string string -> boolean ;; whitespace-string=? : string string -> boolean
;; determines if two strings are equal, up to their whitespace. ;; determines if two strings are equal, up to their whitespace.
@ -60,59 +62,64 @@
[else #f]))) [else #f])))
;; whitespace-string=? tests ;; whitespace-string=? tests
'(map (lambda (x) (apply equal? x)) (module+ test
(list (list #t (whitespace-string=? "a" "a")) (require rackunit)
(list #f (whitespace-string=? "a" "A")) (check-equal? #t (whitespace-string=? "a" "a"))
(list #f (whitespace-string=? "a" " ")) (check-equal? #f (whitespace-string=? "a" "A"))
(list #f (whitespace-string=? " " "A")) (check-equal? #f (whitespace-string=? "a" " "))
(list #t (whitespace-string=? " " " ")) (check-equal? #f (whitespace-string=? " " "A"))
(list #t (whitespace-string=? " " " ")) (check-equal? #t (whitespace-string=? " " " "))
(list #t (whitespace-string=? " " " ")) (check-equal? #t (whitespace-string=? " " " "))
(list #t (whitespace-string=? " " " ")) (check-equal? #t (whitespace-string=? " " " "))
(list #t (whitespace-string=? "a a" "a a")) (check-equal? #t (whitespace-string=? " " " "))
(list #t (whitespace-string=? "a a" "a a")) (check-equal? #t (whitespace-string=? "a a" "a a"))
(list #t (whitespace-string=? "a a" "a a")) (check-equal? #t (whitespace-string=? "a a" "a a"))
(list #t (whitespace-string=? " a" "a")) (check-equal? #t (whitespace-string=? "a a" "a a"))
(list #t (whitespace-string=? "a" " a")) (check-equal? #t (whitespace-string=? " a" "a"))
(list #t (whitespace-string=? "a " "a")) (check-equal? #t (whitespace-string=? "a" " a"))
(list #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<%>) ;;; find-labelled-window : (union ((union #f string) -> window<%>)
;;; ((union #f string) (union #f class) -> window<%>) ;;; ((union #f string) (union #f class) -> window<%>)
;;; ((union #f string) (union class #f) area-container<%> -> window<%>)) ;;; ((union #f string) (union class #f) area-container<%> -> window<%>))
;;;; may call error, if no control with the label is found ;;;; may call error, if no control with the label is found
(define find-labelled-window (define (find-labelled-window label
(opt-lambda (label [class #f]
[class #f] [window (get-top-level-focus-window)]
[window (get-top-level-focus-window)] [failure (λ ()
[failure (lambda () (error 'find-labelled-window "no window labelled ~e in ~e~a"
(error 'find-labelled-window "no window labelled ~e in ~e~a" label
label window
window (if class
(if class (format " matching class ~e" class)
(format " matching class ~e" class) "")))])
"")))]) (define windows (find-labelled-windows label class window))
(unless (or (not label) (cond
(string? label)) [(null? windows) (failure)]
(error 'find-labelled-window "first argument must be a string or #f, got ~e; other args: ~e ~e" [else (car windows)]))
label class window))
(unless (or (class? class) (define (find-labelled-windows label [class #f] [window (get-top-level-focus-window)])
(not class)) (unless (or (not label)
(error 'find-labelled-window "second argument must be a class or #f, got ~e; other args: ~e ~e" (string? label))
class label window)) (error 'find-labelled-windows "first argument must be a string or #f, got ~e; other args: ~e ~e"
(unless (is-a? window area-container<%>) label class window))
(error 'find-labelled-window "third argument must be a area-container<%>, got ~e; other args: ~e ~e" (unless (or (class? class)
window label class)) (not class))
(let ([ans (error 'find-labelled-windows "second argument must be a class or #f, got ~e; other args: ~e ~e"
(let loop ([window window]) class label window))
(cond (unless (is-a? window area-container<%>)
[(and (or (not class) (error 'find-labelled-windows "third argument must be a area-container<%>, got ~e; other args: ~e ~e"
(is-a? window class)) window label class))
(let ([win-label (and (is-a? window window<%>) (let loop ([window window])
(send window get-label))]) (cond
(equal? label win-label))) [(and (or (not class)
window] (is-a? window class))
[(is-a? window area-container<%>) (ormap loop (send window get-children))] (let ([win-label (and (is-a? window window<%>)
[else #f]))]) (send window get-label))])
(or ans (equal? label win-label)))
(failure)))))) (list window)]
[(is-a? window area-container<%>) (apply append (map loop (send window get-children)))]
[else '()])))