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
structure in the parens.})
(thing-doc
color:misspelled-text-color-style-name
string?
@{The name of the style used to color misspelled words. See also
@method[color:text<%> get-spell-check-strings].})
(proc-doc/names
text:range? (-> any/c boolean?) (arg)
@{Determines if @racket[arg] is an instance of the @tt{range} struct.})

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

@ -1,11 +1,14 @@
#lang racket/base
(require racket/system
racket/match
racket/contract)
racket/contract
racket/port
string-constants)
(provide/contract
[query-aspell (-> (and/c string? (not/c #rx"[\n]")) (listof (list/c number? number?)))]
[find-aspell-binary-path (-> (or/c path? #f))])
[find-aspell-binary-path (-> (or/c path? #f))]
[aspell-problematic? (-> (or/c string? #f))])
(define aspell-candidate-paths
'("/usr/bin"
@ -25,6 +28,41 @@
(and (file-exists? c2)
c2)))))
(define (start-aspell asp)
(define aspell? (regexp-match? #rx"aspell" (path->string asp)))
(apply process* asp "-a" (if aspell? '("--encoding=utf-8") '())))
(define (aspell-problematic?)
(define asp (find-aspell-binary-path))
(cond
[(not asp)
(string-constant cannot-find-ispell-or-aspell-path)]
[else
(define proc-lst (start-aspell asp))
(define stdout (list-ref proc-lst 0))
(define stderr (list-ref proc-lst 3))
(close-output-port (list-ref proc-lst 1)) ;; close stdin
(close-input-port stdout)
(define sp (open-output-string))
(copy-port stderr sp)
(define errmsg (get-output-string sp))
(close-input-port stderr)
(cond
[(not (equal? errmsg ""))
(string-append
(format (string-constant spell-program-wrote-to-stderr-on-startup) asp)
"\n\n"
errmsg)]
[else #f])]))
(define asp-logger (make-logger 'framework/aspell (current-logger)))
(define-syntax-rule
(asp-log arg)
(when (log-level? asp-logger 'debug)
(asp-log/proc arg)))
(define (asp-log/proc arg)
(log-message asp-logger 'debug arg (current-continuation-marks)))
(define aspell-req-chan (make-channel))
(define aspell-thread #f)
(define (start-aspell-thread)
@ -40,12 +78,13 @@
(set! already-attempted-aspell? #t)
(define asp (find-aspell-binary-path))
(when asp
(define aspell? (regexp-match? #rx"aspell" (path->string asp)))
(set! aspell-proc (apply process* asp "-a" (if aspell? '("--encoding=utf-8") '())))
(define line (read-line (list-ref aspell-proc 0)))
(log-info (format "framework: started speller: ~a" line))
(set! aspell-proc (start-aspell asp))
(define line (with-handlers ((exn:fail? exn-message))
(read-line (list-ref aspell-proc 0))))
(asp-log (format "framework: started speller: ~a" line))
(when (regexp-match #rx"[Aa]spell" line)
(when (and (string? line)
(regexp-match #rx"[Aa]spell" line))
;; put aspell in "terse" mode
(display "!\n" (list-ref aspell-proc 1))
(flush-output (list-ref aspell-proc 1)))
@ -57,11 +96,11 @@
(define l (with-handlers ((exn:fail? void))
(read-line stderr)))
(when (string? l)
(log-warning (format "aspell-proc stderr: ~a" l))
(asp-log (format "aspell-proc stderr: ~a" l))
(loop))))))))
(define (shutdown-aspell why)
(log-warning (format "aspell.rkt: shutdown connection to aspell: ~a" why))
(asp-log (format "aspell.rkt: shutdown connection to aspell: ~a" why))
(define proc (list-ref aspell-proc 4))
(close-input-port (list-ref aspell-proc 0))
(close-output-port (list-ref aspell-proc 1))
@ -94,7 +133,12 @@
(define check-on-aspell (sync/timeout .5 stdout))
(cond
[check-on-aspell
(define l (read-line stdout))
(define l (with-handlers ((exn:fail? (λ (x)
(asp-log
(format "error reading stdout of aspell process: ~a"
(exn-message x)))
eof)))
(read-line stdout)))
(cond
[(eof-object? l)
(send-resp '())

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

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

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%
[parent panel]
[button-up
(λ ()
(collect-garbage)
(update-memory-text))]
(λ (evt)
(cond
[(or (send evt get-alt-down)
(send evt get-control-down))
(dynamic-require 'framework/private/follow-log #f)]
[else
(collect-garbage)
(update-memory-text)]))]
[init-width "99.99 MB"])])
(set! memory-canvases (cons ec memory-canvases))
(update-memory-text)
@ -890,6 +895,7 @@
(inherit min-client-height min-client-width get-dc get-client-size refresh)
(init init-width)
(init-field [button-up #f])
(init-field [char-typed void])
(define str "")
(define/public (set-str _str)
(set! str _str)
@ -913,7 +919,11 @@
(let-values ([(cw ch) (get-client-size)])
(when (and (<= (send evt get-x) cw)
(<= (send evt get-y) ch))
(button-up))))))
(if (procedure-arity-includes? button-up 1)
(button-up evt)
(button-up)))))))
(define/override (on-char evt)
(char-typed evt))
(super-new (style '(transparent no-focus)))
(let ([dc (get-dc)])
(let-values ([(_1 th _2 _3) (send dc get-text-extent str)])

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

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

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)]
[last-para (and last
(position-paragraph last))])
(letrec
(letrec
([find-offset
(λ (start-pos)
(define tab-char? #f)

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

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

24
collects/framework/test.rkt
View File

@ -253,22 +253,26 @@
(define object-tag 'test:find-object)
;; find-object : class (union string (object -> boolean)) -> object
;; find-object : class (union string regexp (object -> boolean)) -> object
(define (find-object obj-class b-desc)
(λ ()
(cond
[(or (string? b-desc)
(regexp? b-desc)
(procedure? b-desc))
(let* ([active-frame (test:get-active-top-level-window)]
[_ (unless active-frame
(error object-tag
"could not find object: ~a, no active frame"
"could not find object: ~e, no active frame"
b-desc))]
[child-matches?
(λ (child)
(cond
[(string? b-desc)
(equal? (send child get-label) b-desc)]
[(regexp? b-desc)
(and (send child get-label)
(regexp-match? b-desc (send child get-label)))]
[(procedure? b-desc)
(b-desc child)]))]
[found
@ -287,13 +291,13 @@
(send panel get-children)))])
(or found
(error object-tag
"no object of class ~a named ~e in active frame"
"no object of class ~e named ~e in active frame"
obj-class
b-desc)))]
[(is-a? b-desc obj-class) b-desc]
[else (error
object-tag
"expected either a string or an object of class ~a as input, received: ~a"
"expected either a string or an object of class ~e as input, received: ~e"
obj-class b-desc)])))
@ -317,7 +321,7 @@
[else
(update-control ctrl)
(send ctrl command event)
(void)]))))))
(void)]))))))
;;
;; BUTTON
@ -936,7 +940,8 @@
(proc-doc/names
test:keystroke
(->* ((or/c char? symbol?))
((listof (symbols 'alt 'control 'meta 'shift 'noalt 'nocontrol 'nometea 'noshift)))
((listof (or/c 'alt 'control 'meta 'shift
'noalt 'nocontrol 'nometea 'noshift)))
void?)
((key)
((modifier-list null)))
@ -973,10 +978,11 @@
(proc-doc/names
test:mouse-click
(->*
((symbols 'left 'middle 'right)
((or/c 'left 'middle 'right)
(and/c exact? integer?)
(and/c exact? integer?))
((listof (symbols 'alt 'control 'meta 'shift 'noalt 'nocontrol 'nometa 'noshift)))
((listof (or/c 'alt 'control 'meta 'shift 'noalt
'nocontrol 'nometa 'noshift)))
void?)
((button x y)
((modifiers null)))
@ -985,7 +991,7 @@
@method[canvas<%> on-event] method.
Use @racket[test:button-push] to click on a button.
On the Macintosh, @racket['right] corresponds to holding down the command
Under Mac OS X, @racket['right] corresponds to holding down the command
modifier key while clicking and @racket['middle] cannot be generated.
Under Windows, @racket['middle] can only be generated if the user has a

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

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

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

@ -329,7 +329,7 @@
(send blue get-value)))]
[install-color
(lambda (color)
(send red set-value (send color red))
(send red set-value (send color red))
(send green set-value (send color green))
(send blue set-value (send color blue))
(send canvas refresh))])

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-scroll-size 10)
(define canvas-control-border-extra (case (system-type)
[(windows) 2]
[else 0]))
(define canvas-control-border-extra
(case (system-type)
[(windows) 2]
[else 0]))
(define canvas<%>
(interface (subwindow<%>)

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

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

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

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

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

@ -465,6 +465,6 @@
(define (menu-or-bar-parent who p)
(unless (or (is-a? p internal-menu<%>) (is-a? p menu-bar%))
(unless (is-a? p menu-item-container<%>)
(raise-arguments-error (constructor-name who) "(is-a?/c menu-item-container<%>)" p))
(raise-argument-error (constructor-name who) "(is-a?/c menu-item-container<%>)" p))
(raise-arguments-error (who->name who) "invalid parent;\n given parent is not an instance of a built-in menu item container class"
"given parent" p)))

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

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

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

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

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

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

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

@ -6,6 +6,7 @@
ffi/unsafe
ffi/unsafe/objc
"utils.rkt"
"const.rkt"
"types.rkt"
"frame.rkt"
"window.rkt"
@ -63,9 +64,10 @@
file-creator-and-type
file-selector
key-symbol-to-menu-key
needs-grow-box-spacer?)
needs-grow-box-spacer?
get-current-mouse-state)
(import-class NSScreen NSCursor NSMenu)
(import-class NSScreen NSCursor NSMenu NSEvent)
(define (find-graphical-system-path what)
#f)
@ -192,3 +194,28 @@
(define (needs-grow-box-spacer?)
(not (version-10.7-or-later?)))
;; ------------------------------------------------------------
;; Mouse and modifier-key state
(define (get-current-mouse-state)
(define posn (tell #:type _NSPoint NSEvent mouseLocation))
(define buttons (tell #:type _NSUInteger NSEvent pressedMouseButtons))
(define mods (tell #:type _NSUInteger NSEvent modifierFlags))
(define (maybe v mask sym)
(if (zero? (bitwise-and v mask))
null
(list sym)))
(define h (let ([f (tell #:type _NSRect (tell NSScreen mainScreen) frame)])
(NSSize-height (NSRect-size f))))
(values (make-object point%
(->long (NSPoint-x posn))
(->long (- (- h (NSPoint-y posn)) (get-menu-bar-height))))
(append
(maybe buttons #x1 'left)
(maybe buttons #x2 'right)
(maybe mods NSShiftKeyMask 'shift)
(maybe mods NSCommandKeyMask 'meta)
(maybe mods NSAlternateKeyMask 'alt)
(maybe mods NSControlKeyMask 'control)
(maybe mods NSAlphaShiftKeyMask 'caps))))

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

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

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-logger (make-logger 'gui-event (current-logger)))
;; start? : boolean -- indicates if this is a start of an event being handled or not
;; msec : start time if start? is #t, delta from start to end if start? is #f
;; name : (or/c #f symbol?)
(struct gui-event (start end name) #:prefab)
(define (handle-event thunk e)
(call-with-continuation-prompt ; to delimit continuations
(lambda ()
(call-with-continuation-prompt ; to delimit search for dispatch-event-key
(lambda ()
;; communicate the thunk to `really-dispatch-event':
(define before (current-inexact-milliseconds))
(when (log-level? event-logger 'debug)
(log-message event-logger 'debug
"starting to handle an event"
(gui-event before #f (object-name thunk))))
(let ([b (box thunk)])
;; use the event-dispatch handler:
(with-continuation-mark dispatch-event-key b
@ -452,7 +463,13 @@
;; to the original one, then do so now:
(when (unbox b)
(set-box! b #f)
(thunk))))
(thunk)))
(define after (current-inexact-milliseconds))
(when (log-level? event-logger 'debug)
(log-message event-logger 'debug
(format "handled an event: ~a msec"
(- after before))
(gui-event before after (object-name thunk)))))
dispatch-event-prompt))))
(define yield

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

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

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

@ -22,7 +22,8 @@
display-origin
display-size
display-count
location->window))
location->window
get-current-mouse-state))
;; ----------------------------------------
@ -57,6 +58,13 @@
(define-gtk gtk_window_resize (_fun _GtkWidget _int _int -> _void))
(define-gdk gdk_window_set_cursor (_fun _GdkWindow _pointer -> _void))
(define-gdk gdk_screen_get_root_window (_fun _GdkScreen -> _GdkWindow))
(define-gdk gdk_window_get_pointer (_fun _GdkWindow
(x : (_ptr o _int))
(y : (_ptr o _int))
(mods : (_ptr o _uint))
-> _GdkWindow
-> (values x y mods)))
(define-gtk gtk_window_iconify (_fun _GtkWindow -> _void))
(define-gtk gtk_window_deiconify (_fun _GtkWindow -> _void))
@ -169,7 +177,7 @@
(values vbox-gtk panel-gtk))))
(gtk_widget_show vbox-gtk)
(gtk_widget_show panel-gtk)
(connect-key-and-mouse gtk)
(connect-enter-and-leave gtk)
(unless is-dialog?
(gtk_window_set_icon_list gtk (cdr (force icon-pixbufs+glist))))
@ -424,7 +432,7 @@
(define/override (call-pre-on-char w e)
(pre-on-char w e))
(define/override (client-to-screen x y)
(define/override (internal-client-to-screen x y)
(gtk_window_set_gravity gtk GDK_GRAVITY_STATIC)
(let-values ([(dx dy) (gtk_window_get_position gtk)]
[(cdx cdy) (get-client-delta)])
@ -543,3 +551,24 @@
[fh (send f get-height)])
(<= fy y (+ fy fh)))
f))))
;; ----------------------------------------
(define (get-current-mouse-state)
(define-values (x y mods) (gdk_window_get_pointer
(gdk_screen_get_root_window
(gdk_screen_get_default))))
(define (maybe mask sym)
(if (zero? (bitwise-and mods mask))
null
(list sym)))
(values (make-object point% x y)
(append
(maybe GDK_BUTTON1_MASK 'left)
(maybe GDK_BUTTON2_MASK 'middle)
(maybe GDK_BUTTON3_MASK 'right)
(maybe GDK_SHIFT_MASK 'shift)
(maybe GDK_LOCK_MASK 'caps)
(maybe GDK_CONTROL_MASK 'control)
(maybe GDK_MOD1_MASK 'alt)
(maybe GDK_META_MASK 'meta))))

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

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

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

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

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

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

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

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

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

@ -102,13 +102,13 @@
(SendMessageW hwnd CB_RESETCONTENT 0 0)
(set! num-choices 0)))
(public [append* append])
(define (append* str)
(atomically
(SendMessageW/str hwnd CB_ADDSTRING 0 str)
(set! num-choices (add1 num-choices))
(when (= 1 num-choices) (set-selection 0))))))
(when (= 1 num-choices) (set-selection 0))))
(define/public (delete i)
(set! num-choices (sub1 num-choices))
(void (SendMessageW hwnd CB_DELETESTRING i 0)))))

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

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

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

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

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

@ -43,6 +43,7 @@
get-highlight-text-color
check-for-break)
flush-display
get-current-mouse-state
fill-private-color
play-sound
location->window
@ -116,3 +117,26 @@
(define (check-for-break) #f)
(define (needs-grow-box-spacer?) #f)
(define-user32 GetCursorPos (_wfun (p : (_ptr o _POINT)) -> (r : _BOOL)
-> (if r
p
(failed 'GetCursorPos))))
(define-user32 GetAsyncKeyState (_wfun _int -> _SHORT))
(define-user32 GetSystemMetrics (_wfun _int -> _int))
(define SM_SWAPBUTTON 23)
(define (get-current-mouse-state)
(define p (GetCursorPos))
(define (maybe vk sym)
(if (negative? (GetAsyncKeyState vk))
(list sym)
null))
(define swapped? (not (zero? (GetSystemMetrics SM_SWAPBUTTON))))
(values (make-object point% (POINT-x p) (POINT-y p))
(append
(maybe (if swapped? VK_RBUTTON VK_LBUTTON) 'left)
(maybe (if swapped? VK_LBUTTON VK_RBUTTON) 'right)
(maybe VK_LSHIFT 'shift)
(maybe VK_CONTROL 'control)
(maybe VK_MENU 'alt)
(maybe VK_CAPITAL 'caps))))

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

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

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

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

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

@ -59,7 +59,7 @@
(define wx-label-panel%
(class wx-control-horizontal-panel%
(init proxy parent label style font halign valign)
(inherit area-parent skip-enter-leave-events)
(inherit area-parent skip-enter-leave-events set-event-positions-wrt)
(define c #f)
(define/override (enable on?) (if c (send c enable on?) (void)))
@ -77,9 +77,21 @@
(define/public (set-label s) (when l (send l set-label s)))
(define/public (get-label) (and l (send l get-label)))
(define/override (client-to-screen x y)
(if c
(send c client-to-screen x y)
(super client-to-screen x y)))
(define/override (screen-to-client x y)
(if c
(send c screen-to-client x y)
(super screen-to-client x y)))
(define/public (get-p) p)
(define/public (set-c v sx? sy?)
(set! c v)
(set-event-positions-wrt c)
(when l (send l set-event-positions-wrt c))
(when p (send p set-event-positions-wrt c))
(send c stretchable-in-x sx?)
(send c stretchable-in-y sy?)
(send c skip-subwindow-events? #t))))
@ -113,7 +125,8 @@
(get-selection)
(number)
(clear)
(append lbl))
(append lbl)
(delete i))
(stretchable-in-y #f)
(stretchable-in-x #f)))

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

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

95
collects/mrlib/graph.rkt
View File

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

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
id->constructor
id->constructor
(struct-out point)
(struct-out bb))

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

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

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

@ -154,6 +154,17 @@
Sets the currently active regions to be @racket[regions].
}
@defmethod[(get-spell-check-strings) boolean?]{
Returns @racket[#t] if the colorer will attempt to
spell-check string constants.
}
@defmethod[(set-spell-check-strings [b? boolean?]) void?]{
If called with @racket[#t], tell the colorer to spell-check
string constants. Otherwise, disable spell-checking of constants.
}
@defmethod*[(((get-regions) (listof (list/c number? (or/c (quote end) number?)))))]{
This returns the list of regions that are currently being colored in the
editor.

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?]
[width-default exact-nonnegative-integer?]
[#:allow-funny? allow-funny? boolean? #f]
[#:frame-icon
[#:frame-icon
frame-icon
(or/c #f
(is-a?/c bitmap%)

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

@ -1,5 +1,9 @@
#lang scribble/doc
@(require "common.rkt")
@(require "common.rkt"
scribble/eval)
@(define editor-eval (make-base-eval))
@(editor-eval '(require racket/class))
@definterface/title[editor<%> ()]{
@ -206,7 +210,52 @@ See also @method[editor<%> refresh-delayed?] and @method[editor<%>
If the @racket[undoable?] flag is @racket[#f], then the changes made
in the sequence cannot be reversed through the @method[editor<%>
undo] method. This flag is only effective for the outermost
undo] method. To accomplish this, the editor just does not add
entries to the undo log when in an edit sequence where the
@racket[undoable?] flag is @racket[#f]. So, for example, if an
@litchar{a} is inserted into the editor and then a @litchar{b}
is inserted, and then an un-undoable edit-sequence begins,
and the @litchar{a} is colored red, and then the edit-sequence ends,
then an undo will remove the @litchar{b}, leaving the @litchar{a}
colored red.
This behavior also means that editors can get confused. Consider
this program:
@examples[#:eval
editor-eval
(eval:alts (define t (new text%))
;; this is a pretty horrible hack, but
;; the sequence of calls below behaves
;; the way they are predicted to as of
;; the moment of this commit
(define t
(new (class object%
(define/public (set-max-undo-history x) (void))
(define/public (insert . args) (void))
(define/public (begin-edit-sequence a b) (void))
(define/public (end-edit-sequence) (void))
(define/public (undo) (void))
(define first? #t)
(define/public (get-text)
(cond
[first?
(set! first? #f)
"cab"]
[else "cb"]))
(super-new)))))
(send t set-max-undo-history 'forever)
(send t insert "a")
(send t insert "b")
(send t begin-edit-sequence #f #f)
(send t insert "c" 0 0)
(send t end-edit-sequence)
(send t get-text)
(send t undo)
(send t get-text)]
You might hope that the undo would remove the @litchar{b}, but it removes
the @litchar{a}.
The @racket[undoable?] flag is only effective for the outermost
@method[editor<%> begin-edit-sequence] when nested sequences are
used. Note that, for a @racket[text%] object, the character-inserting
version of @method[text% insert] interferes with sequence-based undo

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.}
@defmethod[(delete [n exact-nonnegative-integer?])
void?]{
Deletes the item indexed by @racket[n]. @|lbnumnote| If @racket[n] is equal
to or larger than the number of items in the control, @|MismatchExn|.
Selected items that are not deleted remain selected, and no other
items are selected.}
@defmethod[(delete-column [n exact-nonnegative-integer?])
void?]{

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

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

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}.}
@defproc[(get-current-mouse-state) (values (is-a?/c point%)
(listof (or/c 'left 'middle 'right
'shift 'control 'alt 'meta 'caps)))]{
Returns the current location of the mouse in screen coordinates,
and returns a list of symbols for mouse buttons and modifier keys
that are currently pressed.}
@defproc[(hide-cursor-until-moved) void?]{
Hides the cursor until the user moves the mouse or clicks the mouse

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
outside of the same callback.
@subsection{Logging}
The GUI system logs the timing of when events are handled and how
long they take to be handled. Each event that involves a callback
into Racket code has two events logged, both of which use
the @racket[gui-event] struct:
@racketblock[(struct gui-event (start end name) #:prefab)]
The @racket[_start] field is the result of @racket[(current-inexact-milliseconds)]
when the event handling starts. The @racket[_end] field is
@racket[#f] for the log message when the event handling starts,
and the result of @racket[(current-inexact-milliseconds)] when
it finishes for the log message when an event finishes.
The @racket[_name] field is
the name of the function that handled the event; in the case of a
@racket[queue-callback]-based event, it is the name of the thunk passed to
@racket[queue-callback].
@section[#:tag "animation"]{Animation in Canvases}
The content of a canvas is buffered, so if a canvas must be redrawn,

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

@ -304,6 +304,62 @@
(test #f 'peek-t (peek-byte-or-special i 0))
(test 49 'read-1 (peek-byte-or-special i 1))))
(let ()
(define t (new text%))
(send t insert "aa\nbb\ncc\ndd\nee\nff\n")
(send t insert (make-object image-snip%
(collection-file-path "recycle.png" "icons")))
(define p (open-input-text-editor t))
(define rev-at-start (send t get-revision-number))
(define line1 (read-line p))
(define sl (send t get-style-list))
(define d (make-object style-delta% 'change-bold))
(define s (send sl find-or-create-style (send sl basic-style) d))
(send t change-style s 6 7)
(define rev-after-cs (send t get-revision-number))
(define line2 (read-line p))
(test #t 'revision-changed (> rev-after-cs rev-at-start))
(test "aa" 'revision-changed-line1 line1)
(test "bb" 'revision-changed-line1 line2))
(let ()
(define t (new text%))
(send t insert "abcd\n")
(send t insert (make-object image-snip%
(collection-file-path "recycle.png" "icons")))
(define (count-snips)
(let loop ([s (send t find-first-snip)])
(cond
[s (+ 1 (loop (send s next)))]
[else 0])))
(send t split-snip 1)
(define before-snip-count (count-snips))
(define rev-at-start (send t get-revision-number))
(define p (open-input-text-editor t))
(define char1 (read-char p))
(define s (send (send t get-style-list) basic-style))
(send t change-style s 0 4)
(define after-snip-count (count-snips))
(define rev-after-cs (send t get-revision-number))
(define chars (string (read-char p) (read-char p) (read-char p)))
(test 4 'snips-joined1 before-snip-count)
(test 3 'snips-joined2 after-snip-count)
(test #t 'snips-joined3 (> rev-after-cs rev-at-start))
(test #\a 'snips-joined4 char1)
(test "bcd" 'snips-joined5 chars))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Snips and Streams ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -325,6 +381,7 @@
snip))
(super-instantiate ())))
(define snip-class (make-object (mk-number-snip-class% #t)))
(send snip-class set-classname (format "~s" `(lib "number-snip.ss" "drscheme" "private")))
(send (get-the-snip-class-list) add snip-class)

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

@ -1556,13 +1556,11 @@
(when (<= 0 p (sub1 (length actual-content)))
(set! actual-content (gone actual-content p))
(set! actual-user-data (gone actual-user-data p))))
(define db (if list?
(make-object button%
"Delete" cdp
(lambda (b e)
(let ([p (send c get-selection)])
(delete p))))
null))
(define db (make-object button%
"Delete" cdp
(lambda (b e)
(let ([p (send c get-selection)])
(delete p)))))
(define dab (if list?
(make-object button%
"Delete Above" cdp
@ -2291,6 +2289,30 @@
'(arrow bullseye cross hand ibeam watch blank size-n/s size-e/w size-ne/sw size-nw/se))
(send f show #t))
;----------------------------------------------------------------------
(define (mouse)
(define f (new frame%
[label "Mouse"]
[width 300]
[height 200]))
(define m (new message%
[parent f]
[label ""]
[stretchable-width #t]))
(send f show #t)
(thread (lambda ()
(let loop ()
(when (send f is-shown?)
(sleep 0.1)
(define-values (pos keys) (get-current-mouse-state))
(queue-callback
(lambda () (send m set-label
(format "~a,~a ~a"
(send pos get-x)
(send pos get-y)
keys))))
(loop))))))
;----------------------------------------------------------------------
@ -2372,6 +2394,8 @@
(make-object vertical-pane% crp) ; filler
(make-object button% "Cursors" crp (lambda (b e) (cursors)))
(make-object vertical-pane% crp) ; filler
(make-object button% "Mouse" crp (lambda (b e) (mouse)))
(make-object vertical-pane% crp) ; filler
(make-object button% "Make Radiobox Frame" crp (lambda (b e) (radiobox-frame)))
(define cp (make-object horizontal-pane% ap))
(send cp stretchable-width #f)

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

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

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

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