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 '())

152
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,25 +289,49 @@ 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/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 in-lexer-mode))
(get-token in in-start-pos lexer-mode))
;(define-values (_line2 _col2 pos-after) (port-next-location in))
(enable-suspend #t)
(unless (eq? 'eof type)
(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 (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)))
(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))
@ -352,10 +363,9 @@ added get-regions
(insert-last! (lexer-state-tokens ls)
(lexer-state-invalid-tokens ls))
(set-lexer-state-invalid-tokens-start! ls +inf.0)
(enable-suspend #t)]
(re-tokenize-move-to-next-ls start-time #t)]
[else
(enable-suspend #t)
(re-tokenize ls in in-start-pos new-lexer-mode enable-suspend)]))))
(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))

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

@ -796,9 +796,14 @@
[ec (new position-canvas%
[parent panel]
[button-up
(λ ()
(λ (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))]
(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)])

2
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%)])

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)

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

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

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

@ -19,7 +19,8 @@
(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)
(define canvas-control-border-extra
(case (system-type)
[(windows) 2]
[else 0]))

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

9
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)
@ -843,10 +846,6 @@
(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)))

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

@ -91,15 +91,17 @@
void))))
;; General case, which handles non-text context:
(with-method ([gsp (text get-snip-position)]
[grn (text get-revision-number)])
[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 (to-str)
(lambda (skip to-str)
(if snip
(let ([snip-start (gsp snip)])
(cond
@ -109,8 +111,9 @@
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)
(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)
@ -120,13 +123,18 @@
0)))]
[next-snip
(lambda (to-str)
(unless (= revision (grn))
(raise-arguments-error
'text-input-port
"editor has changed since port was opened"
"editor" text))
(cond
[(= revision (grn))
(set! snip (send-generic snip next-generic))
(update-str-to-snip to-str))]
(set! snip-end-position (and snip (+ (gsp snip) (send-generic snip get-count-generic))))
(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?
@ -171,7 +179,7 @@
(- end snip-start))])
(set! next? #t)
(display (send-generic snip get-text-generic skip c) pipe-w))
(update-str-to-snip empty-string))
(update-str-to-snip 0 empty-string))
port)))))))
(define (jump-to-submodule in-port expected-module k)

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

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

@ -35,6 +35,7 @@
connect-focus
connect-key-and-mouse
connect-enter-and-leave
do-button-event
(struct-out GtkRequisition) _GtkRequisition-pointer
@ -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?
@ -341,7 +345,16 @@
[(1) 'left-up]
[(3) 'right-up]
[else 'middle-up])])]
[m (new mouse-event%
[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]
@ -355,13 +368,8 @@
[(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))]
[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)]
@ -369,7 +377,7 @@
[time-stamp ((if motion? GdkEventMotion-time
(if crossing? GdkEventCrossing-time GdkEventButton-time))
event)]
[caps-down (bit? modifiers GDK_LOCK_MASK)])])
[caps-down (bit? modifiers GDK_LOCK_MASK)]))])
(if (send wx handles-events? gtk)
(begin
(queue-window-event wx (lambda ()
@ -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))

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

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

87
collects/mrlib/graph.rkt
View File

@ -3,6 +3,7 @@
racket/list
racket/math
racket/gui/base
racket/match
(for-syntax racket/base)
racket/contract)
@ -387,8 +388,7 @@
(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)
(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)
(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)]))))
(+ (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))

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

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

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.

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)

32
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%
(define db (make-object button%
"Delete" cdp
(lambda (b e)
(let ([p (send c get-selection)])
(delete p))))
null))
(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)

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

@ -280,4 +280,3 @@
(still)))
(do-test)

73
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,50 +62,55 @@
[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
(define (find-labelled-window label
[class #f]
[window (get-top-level-focus-window)]
[failure (lambda ()
[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-window "first argument must be a string or #f, got ~e; other args: ~e ~e"
(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-window "second argument must be a class or #f, got ~e; other args: ~e ~e"
(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-window "third argument must be a area-container<%>, got ~e; other args: ~e ~e"
(error 'find-labelled-windows "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)
@ -111,8 +118,8 @@
(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))))))
(list window)]
[(is-a? window area-container<%>) (apply append (map loop (send window get-children)))]
[else '()])))