From 9767fde76db101837a9ffc6fddf43c48be73288a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 24 Oct 2012 23:45:38 -0500 Subject: [PATCH 01/32] improve the performance for dragging around items in mrlib/graph (used by Redex's traces window and the module browser) original commit: 9d4a3a6e07545cfad5ad38072ddaf2862eb9475a --- collects/mrlib/graph.rkt | 78 ++++++++++++++++++++-------------------- 1 file changed, 40 insertions(+), 38 deletions(-) diff --git a/collects/mrlib/graph.rkt b/collects/mrlib/graph.rkt index a87e68f0..62a702ba 100644 --- a/collects/mrlib/graph.rkt +++ b/collects/mrlib/graph.rkt @@ -3,7 +3,8 @@ racket/list racket/math racket/gui/base - (for-syntax racket/base) + racket/match + (for-syntax racket/base) racket/contract) (provide graph-snip<%> @@ -401,57 +402,58 @@ ;; 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<%>) + (unless (eq? last-dc dc) + (define-values (w h a s) (send dc get-text-extent "Label" #f #f 0)) + (set! last-dc dc) + (set! text-height h)) (let* ([parents-and-children (append (get-all-parents snip) (get-all-children snip))] - [rects (eliminate-redundancies (get-rectangles snip parents-and-children))] + [rects (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)))]) + (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)])))) + (inherit invalidate-bitmap-cache) + (define text-height #f) + (define last-dc #f) - ;; (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) + (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))]))) + (cond + [pending-invalidate-rectangle + (match pending-invalidate-rectangle + [(list l2 t2 r2 b2) + (set! pending-invalidate-rectangle + (list (min l l2) (min t t2) (max r r2) (max b b2)))])] + [else + (set! pending-invalidate-rectangle (list l t r b))]) + (send pending-invalidate-rectangle-timer start 20 #t)) ;; get-rectangles : snip (listof snip) -> rect ;; computes the rectangles that need to be invalidated for connecting @@ -519,7 +521,7 @@ (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) + (unless pending-invalidate-rectangle (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)) From c2da5ef7112be78bef0810fbe8401f6af5fd4c7a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 25 Oct 2012 16:48:54 -0500 Subject: [PATCH 02/32] add logging to mred's event callback mechanism to record how long event processing takes original commit: 7e8ac872fec52fecf84e4ec6d62989e2b9304605 --- collects/mred/private/wx/common/queue.rkt | 19 ++++++++++++++++++- collects/scribblings/gui/win-overview.scrbl | 19 +++++++++++++++++++ 2 files changed, 37 insertions(+), 1 deletion(-) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index fab54e0f..546efb2c 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -438,12 +438,23 @@ (define event-dispatch-handler (make-parameter really-dispatch-event)) +(define event-logger (make-logger 'gui-event (current-logger))) +;; start? : boolean -- indicates if this is a start of an event being handled or not +;; msec : start time if start? is #t, delta from start to end if start? is #f +;; name : (or/c #f symbol?) +(struct gui-event (start? msec 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 #t before (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 #f (- after before) (object-name thunk))))) dispatch-event-prompt)))) (define yield diff --git a/collects/scribblings/gui/win-overview.scrbl b/collects/scribblings/gui/win-overview.scrbl index a3585dd3..1ce753c0 100644 --- a/collects/scribblings/gui/win-overview.scrbl +++ b/collects/scribblings/gui/win-overview.scrbl @@ -951,6 +951,25 @@ 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? msec name) #:prefab)] +The @racket[start?] field is a boolean indicating if this +event is logging the time when an event is starting to be handled, +or when it finishes. In the case that @racket[start?] is @racket[#t], +the @racket[msec] field is the result of +@racket[current-inexact-milliseconds]; when @racket[start?] is @racket[#f], +then the @racket[msec] field is the number of milliseconds that the +event handling took (the difference between @racket[current-inexact-milliseconds]'s +results before and after the handling). 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, From 75ea19d0f4cb10647ec199cde0f0b7544a9edeb5 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 25 Oct 2012 16:57:38 -0500 Subject: [PATCH 03/32] add some first-cut logging information to drracket to track how long events take to be handled original commit: e89a121ae5e42366702a4674cd79b339151175a3 --- collects/framework/private/color.rkt | 5 +- collects/framework/private/logging-timer.rkt | 66 ++++++++++++++++++++ collects/framework/private/text.rkt | 7 ++- 3 files changed, 73 insertions(+), 5 deletions(-) create mode 100644 collects/framework/private/logging-timer.rkt diff --git a/collects/framework/private/color.rkt b/collects/framework/private/color.rkt index ed3196ef..7a6102c5 100644 --- a/collects/framework/private/color.rkt +++ b/collects/framework/private/color.rkt @@ -15,7 +15,8 @@ added get-regions string-constants "../preferences.rkt" "sig.rkt" - "aspell.rkt") + "aspell.rkt" + framework/private/logging-timer) (import [prefix icon: framework:icon^] [prefix mode: framework:mode^] @@ -519,7 +520,7 @@ added get-regions exn)) (set! tok-cor #f)))) #;(printf "begin lexing\n") - (when (coroutine-run 10 tok-cor) + (when (log-timeline "colorer coroutine" (coroutine-run 10 tok-cor)) (for-each (lambda (ls) (set-lexer-state-up-to-date?! ls #t)) lexer-states) diff --git a/collects/framework/private/logging-timer.rkt b/collects/framework/private/logging-timer.rkt new file mode 100644 index 00000000..0c9ad724 --- /dev/null +++ b/collects/framework/private/logging-timer.rkt @@ -0,0 +1,66 @@ +#lang racket/base + +(require racket/gui/base + racket/class + (for-syntax racket/base)) + +(define timeline-logger (make-logger 'timeline (current-logger))) + +(provide logging-timer% + (struct-out timeline-info) + log-timeline) + +(define logging-timer% + (class timer% + (init notify-callback) + (define name (object-name notify-callback)) + (define wrapped-notify-callback + (λ () + (log-timeline + (format "~a timer fired" name) + (notify-callback)))) + (super-new [notify-callback wrapped-notify-callback]) + (define/override (start msec [just-once? #f]) + (log-timeline (format "~a timer started; msec ~s just-once? ~s" name msec just-once?)) + (super start msec just-once?)))) + + +(define-syntax (log-timeline stx) + (syntax-case stx () + [(_ info-string expr) + #'(log-timeline/proc + (and (log-level? timeline-logger 'debug) + info-string) + (λ () expr))] + [(_ info-string) + #'(log-timeline/proc + (and (log-level? timeline-logger 'debug) + info-string) + #f)])) + +(define (log-timeline/proc info expr) + (define start-time (current-inexact-milliseconds)) + (when info + (log-message timeline-logger 'debug + (format "~a start" info) + (timeline-info (if expr 'start 'once) + (current-process-milliseconds) + start-time))) + (when expr + (begin0 + (expr) + (when info + (define end-time (current-inexact-milliseconds)) + (log-message timeline-logger 'debug + (format "~a end; delta ms ~a" info (- end-time start-time)) + (timeline-info start-time + end-time + (current-inexact-milliseconds))))))) + + +;; what : (or/c 'start 'once flonum) +;; flonum means that this is an 'end' event and there should be +;; a start event corresponding to it with that milliseconds +;; process-milliseconds : fixnum +;; milliseconds : flonum -- time of this event +(struct timeline-info (what process-milliseconds milliseconds) #:transparent) diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index 9e8d8d7a..d66f8579 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -11,7 +11,8 @@ "autocomplete.rkt" mred/mred-sig mrlib/interactive-value-port - racket/list) + racket/list + "logging-timer.rkt") (require setup/xref scribble/xref scribble/manual-struct) @@ -1063,7 +1064,7 @@ (when searching-str (unless timer (set! timer - (new timer% + (new logging-timer% [notify-callback (λ () (run-after-edit-sequence @@ -1536,7 +1537,7 @@ ;; have not yet been propogated to the delegate (define todo '()) - (define timer (new timer% + (define timer (new logging-timer% [notify-callback (λ () ;; it should be the case that todo is always '() when the delegate is #f From 7295fab9dee329ffc84ee0ec3571b368c9064cc9 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 26 Oct 2012 21:48:58 -0500 Subject: [PATCH 04/32] clean up rectangle computations, fixing some bugs along the way original commit: 8bc3b70a3c1d521ce8be3844b6efe9829d55fb39 --- collects/mrlib/graph.rkt | 69 ++++++++++++++++------------------------ 1 file changed, 28 insertions(+), 41 deletions(-) diff --git a/collects/mrlib/graph.rkt b/collects/mrlib/graph.rkt index 62a702ba..b466956d 100644 --- a/collects/mrlib/graph.rkt +++ b/collects/mrlib/graph.rkt @@ -378,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)) @@ -387,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), @@ -404,37 +403,20 @@ ;; all of its children and parents. (define/private (invalidate-to-children/parents snip dc) (when (is-a? snip graph-snip<%>) - (unless (eq? last-dc dc) - (define-values (w h a s) (send dc get-text-extent "Label" #f #f 0)) - (set! last-dc dc) - (set! text-height h)) - (let* ([parents-and-children (append (get-all-parents snip) - (get-all-children snip))] - [rects (get-rectangles snip parents-and-children)] - [or/c (or/c-rects rects)] - [invalidate-rect - (lambda (rect) - (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)])))) - (inherit invalidate-bitmap-cache) - (define text-height #f) - (define last-dc #f) + (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))))) (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) @@ -445,15 +427,16 @@ (set! pending-invalidate-rectangle-timer (new timer% [notify-callback (λ () (run-pending-invalidate-rectangle))]))) - (cond - [pending-invalidate-rectangle - (match pending-invalidate-rectangle - [(list l2 t2 r2 b2) - (set! pending-invalidate-rectangle - (list (min l l2) (min t t2) (max r r2) (max b b2)))])] - [else - (set! pending-invalidate-rectangle (list l t r b))]) + (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 @@ -521,7 +504,11 @@ (let ([old-font (send dc get-font)]) (when edge-label-font (send dc set-font edge-label-font)) - (unless pending-invalidate-rectangle (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)) From f5207bb32064183044250f5121867fe7f5470ac1 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 27 Oct 2012 13:04:06 -0500 Subject: [PATCH 05/32] add missing docs for color:misspelled-text-color-style-name original commit: 789ab0d9f00734c1c866cf4ace093f758bee0773 --- collects/framework/main.rkt | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/collects/framework/main.rkt b/collects/framework/main.rkt index c55824ae..c383944b 100644 --- a/collects/framework/main.rkt +++ b/collects/framework/main.rkt @@ -72,6 +72,12 @@ in a GUI, and the color to use. The colors are used to show the nesting structure in the parens.}) + (thing-doc + color:misspelled-text-color-style-name + string? + @{The name of the style used to color misspelled words. See also + @method[color:text<%> get-spell-check-strings].}) + (proc-doc/names text:range? (-> any/c boolean?) (arg) @{Determines if @racket[arg] is an instance of the @tt{range} struct.}) From 894d5a5fb65b8a42f70443e05e9ab37c36aa1299 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 27 Oct 2012 21:31:08 -0600 Subject: [PATCH 06/32] racket/gui gtk: fix on-subwindow-... handling Handling was broken by changes to fix enter and leave events (in commit a5d7812732) Merge to v5.3.1 original commit: ba6e383963de1c5e64058d99efceb799171827a9 --- collects/mred/private/wx/gtk/frame.rkt | 2 +- collects/mred/private/wx/gtk/window.rkt | 8 ++++++-- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index e9fc5a56..fc041d70 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -169,7 +169,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)))) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 87c0d0e6..643f5a13 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -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? From 0cea8f0684a07006824da32a73b0d75ab56e5294 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 29 Oct 2012 06:43:24 -0500 Subject: [PATCH 07/32] adjust the fields of the gui-event struct original commit: 33eba697a0d1fe354768dd8d7c77bacbe9b7ab14 --- collects/mred/private/wx/common/queue.rkt | 6 +++--- collects/scribblings/gui/win-overview.scrbl | 16 +++++++--------- 2 files changed, 10 insertions(+), 12 deletions(-) diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 546efb2c..35ba24af 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -442,7 +442,7 @@ ;; 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? msec name) #:prefab) +(struct gui-event (start end name) #:prefab) (define (handle-event thunk e) (call-with-continuation-prompt ; to delimit continuations @@ -454,7 +454,7 @@ (when (log-level? event-logger 'debug) (log-message event-logger 'debug "starting to handle an event" - (gui-event #t before (object-name thunk)))) + (gui-event before #f (object-name thunk)))) (let ([b (box thunk)]) ;; use the event-dispatch handler: (with-continuation-mark dispatch-event-key b @@ -469,7 +469,7 @@ (log-message event-logger 'debug (format "handled an event: ~a msec" (- after before)) - (gui-event #f (- after before) (object-name thunk))))) + (gui-event before after (object-name thunk))))) dispatch-event-prompt)))) (define yield diff --git a/collects/scribblings/gui/win-overview.scrbl b/collects/scribblings/gui/win-overview.scrbl index 1ce753c0..5c2a5e9d 100644 --- a/collects/scribblings/gui/win-overview.scrbl +++ b/collects/scribblings/gui/win-overview.scrbl @@ -957,15 +957,13 @@ 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? msec name) #:prefab)] -The @racket[start?] field is a boolean indicating if this -event is logging the time when an event is starting to be handled, -or when it finishes. In the case that @racket[start?] is @racket[#t], -the @racket[msec] field is the result of -@racket[current-inexact-milliseconds]; when @racket[start?] is @racket[#f], -then the @racket[msec] field is the number of milliseconds that the -event handling took (the difference between @racket[current-inexact-milliseconds]'s -results before and after the handling). The @racket[name] field is +@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]. From cd33065663d34d17f0b2b28ac3f92bcd607c3232 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 30 Oct 2012 16:58:24 -0500 Subject: [PATCH 08/32] changed the colorer so that it doesn't use a co-routine; instead, refactor it so it doesn't add anything to the continuation ever, and just check if it has been a while since we started (giving other events a chance to run, if so). Also, interleave the calls to change-style with the parsing of the buffer to get a more accurate count of the time the colorer is taking original commit: f07c8cf4907e283ab590b3528534b9784cd12c7f --- collects/framework/private/color.rkt | 243 +++++++++++++-------------- 1 file changed, 117 insertions(+), 126 deletions(-) diff --git a/collects/framework/private/color.rkt b/collects/framework/private/color.rkt index 7a6102c5..fd576783 100644 --- a/collects/framework/private/color.rkt +++ b/collects/framework/private/color.rkt @@ -6,17 +6,15 @@ 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 string-constants "../preferences.rkt" "sig.rkt" - "aspell.rkt" - framework/private/logging-timer) + "aspell.rkt") (import [prefix icon: framework:icon^] [prefix mode: framework:mode^] @@ -238,11 +236,9 @@ 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 + ;; If there is some incomplete coloring waiting to happen + (define colorer-pending? #f) + ;; The editor revision when the last coloring was started (define rev #f) @@ -276,18 +272,9 @@ 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! colorer-pending? #f) (set! rev #f)) - ;; Actually color the buffer. - (define/private (color) - (for ([clr (in-list colorings)]) - (change-style (vector-ref clr 0) (vector-ref clr 1) (vector-ref clr 2) #f)) - (set! colorings '())) - ;; Discard extra tokens at the first of invalid-tokens (define/private (sync-invalid ls) (let ([invalid-tokens (lexer-state-invalid-tokens ls)] @@ -303,60 +290,91 @@ 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 (start-re-tokenize start-time) + (set! re-tokenize-lses lexer-states) + (re-tokenize-move-to-next-ls start-time)) + + (define/private (re-tokenize-move-to-next-ls start-time) + (cond + [(null? re-tokenize-lses) + ;; done: return #t + #t] + [else + (set! re-tokenize-ls-argument (car re-tokenize-lses)) + (set! re-tokenize-lses (cdr re-tokenize-lses)) + (set! re-tokenize-in-start-pos (lexer-state-current-pos re-tokenize-ls-argument)) + (set! re-tokenize-lexer-mode-argument (lexer-state-current-lexer-mode re-tokenize-ls-argument)) + (set! re-tokenize-in-argument + (open-input-text-editor this + (lexer-state-current-pos re-tokenize-ls-argument) + (lexer-state-end-pos re-tokenize-ls-argument) + (λ (x) #f))) + (port-count-lines! re-tokenize-in-argument) + (continue-re-tokenize start-time #t)])) + + (define re-tokenize-lses #f) + (define re-tokenize-ls-argument #f) + (define re-tokenize-in-argument #f) + (define re-tokenize-in-start-pos #f) + (define re-tokenize-lexer-mode-argument #f) + (define/private (continue-re-tokenize start-time did-something?) + (cond + [(and did-something? ((+ start-time 20) . <= . (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 re-tokenize-in-argument re-tokenize-in-start-pos re-tokenize-lexer-mode-argument)) + ;(define-values (_line2 _col2 pos-after) (port-next-location in)) + (cond + [(eq? 'eof type) + (re-tokenize-move-to-next-ls start-time)] + [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)) + #; (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! re-tokenize-ls-argument (+ len (lexer-state-current-pos re-tokenize-ls-argument))) + (set-lexer-state-current-lexer-mode! re-tokenize-ls-argument new-lexer-mode) + (sync-invalid re-tokenize-ls-argument) + (when (and should-color? (should-color-type? type) (not frozen?)) + (add-colorings type re-tokenize-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 re-tokenize-ls-argument) len (make-data type new-lexer-mode backup-delta)) + #; (show-tree (lexer-state-tokens ls)) + (send (lexer-state-parens re-tokenize-ls-argument) add-token data len) + (cond + [(and (not (send (lexer-state-invalid-tokens re-tokenize-ls-argument) is-empty?)) + (= (lexer-state-invalid-tokens-start re-tokenize-ls-argument) + (lexer-state-current-pos re-tokenize-ls-argument)) + (equal? new-lexer-mode + (lexer-state-invalid-tokens-mode re-tokenize-ls-argument))) + (send (lexer-state-invalid-tokens re-tokenize-ls-argument) search-max!) + (send (lexer-state-parens re-tokenize-ls-argument) merge-tree + (send (lexer-state-invalid-tokens re-tokenize-ls-argument) get-root-end-position)) + (insert-last! (lexer-state-tokens re-tokenize-ls-argument) + (lexer-state-invalid-tokens re-tokenize-ls-argument)) + (set-lexer-state-invalid-tokens-start! re-tokenize-ls-argument +inf.0) + (re-tokenize-move-to-next-ls start-time)] + [else + (set! re-tokenize-lexer-mode-argument new-lexer-mode) + (continue-re-tokenize start-time #t)]))])])) (define/private (add-colorings type in-start-pos new-token-start new-token-end) (define sp (+ in-start-pos (sub1 new-token-start))) @@ -377,22 +395,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") @@ -487,52 +506,24 @@ 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 (log-timeline "colorer coroutine" (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) - (end-edit-sequence) - #;(printf "end coloring\n"))) + (define finished? + (cond + [(and colorer-pending? (= rev (get-revision-number))) + (continue-re-tokenize (current-inexact-milliseconds) #f)] + [else + (set! rev (get-revision-number)) + (start-re-tokenize (current-inexact-milliseconds))])) + (cond + [finished? + (set! colorer-pending? #f) + (for-each (lambda (ls) + (set-lexer-state-up-to-date?! ls #t)) + lexer-states) + (update-lexer-state-observers)] + [else + (set! colorer-pending? #t)]) + (end-edit-sequence))) (define/private (colorer-callback) (cond From f0a85b7be2b924bcba508ba679db6e1d18d92437 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 31 Oct 2012 09:42:49 -0500 Subject: [PATCH 09/32] fix a bug in the colorer refactoring As it turns out, changing the color (via change-style) can somtimes split snips, which can change the revision number, which means that the open port into the editor is no longer valid. Since this doesn't seem to happen very much when editing in DrRacket, we just detect this situation and give up on this colorer's port, and hopefully it actually doesn't happen much (the place it happened that let me notice this was when inserting an image via a menu in the drracket test suites) original commit: 226a7140b5784531103e10338785249a37aac677 --- collects/framework/private/color.rkt | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/collects/framework/private/color.rkt b/collects/framework/private/color.rkt index fd576783..58d84c51 100644 --- a/collects/framework/private/color.rkt +++ b/collects/framework/private/color.rkt @@ -310,6 +310,7 @@ added get-regions (lexer-state-end-pos re-tokenize-ls-argument) (λ (x) #f))) (port-count-lines! re-tokenize-in-argument) + (set! rev (get-revision-number)) (continue-re-tokenize start-time #t)])) (define re-tokenize-lses #f) @@ -319,7 +320,8 @@ added get-regions (define re-tokenize-lexer-mode-argument #f) (define/private (continue-re-tokenize start-time did-something?) (cond - [(and did-something? ((+ start-time 20) . <= . (current-inexact-milliseconds))) + [(or (not (= rev (get-revision-number))) + (and did-something? ((+ start-time 20) . <= . (current-inexact-milliseconds)))) #f] [else ;(define-values (_line1 _col1 pos-before) (port-next-location in)) @@ -512,7 +514,6 @@ added get-regions [(and colorer-pending? (= rev (get-revision-number))) (continue-re-tokenize (current-inexact-milliseconds) #f)] [else - (set! rev (get-revision-number)) (start-re-tokenize (current-inexact-milliseconds))])) (cond [finished? From 72533d7a640245b5ebfd74acc99b2f096a769757 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 31 Oct 2012 10:14:39 -0500 Subject: [PATCH 10/32] add docs for get-spell-check-strings and set-spell-check-strings original commit: fdfa5bf134ce215e9b4aac01defe62680acba78a --- collects/scribblings/framework/color.scrbl | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/collects/scribblings/framework/color.scrbl b/collects/scribblings/framework/color.scrbl index 646e96c9..4407978c 100644 --- a/collects/scribblings/framework/color.scrbl +++ b/collects/scribblings/framework/color.scrbl @@ -154,6 +154,17 @@ Sets the currently active regions to be @racket[regions]. } + + @defmethod[(get-spell-check-strings) boolean?]{ + Returns @racket[#t] if the colorer will attempt to + spell-check string constants. + } + + @defmethod[(set-spell-check-strings [b? boolean?]) void?]{ + If called with @racket[#t], tell the colorer to spell-check + string constants. Otherwise, disable spell-checking of constants. + } + @defmethod*[(((get-regions) (listof (list/c number? (or/c (quote end) number?)))))]{ This returns the list of regions that are currently being colored in the editor. From 7581b3e2289c69e7bf8860fa290e37b10b8f1183 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 31 Oct 2012 10:15:28 -0500 Subject: [PATCH 11/32] add logging to the colorer original commit: 9582fe830ae4d0db3b71a02b78d3546521b63bc2 --- collects/framework/private/color.rkt | 17 ++++++++++++++--- 1 file changed, 14 insertions(+), 3 deletions(-) diff --git a/collects/framework/private/color.rkt b/collects/framework/private/color.rkt index 58d84c51..e340683e 100644 --- a/collects/framework/private/color.rkt +++ b/collects/framework/private/color.rkt @@ -320,8 +320,10 @@ added get-regions (define re-tokenize-lexer-mode-argument #f) (define/private (continue-re-tokenize start-time did-something?) (cond - [(or (not (= rev (get-revision-number))) - (and did-something? ((+ start-time 20) . <= . (current-inexact-milliseconds)))) + [(not (= rev (get-revision-number))) + (c-log "revision number changed unexpectedly") + #f] + [(and did-something? ((+ start-time 20) . <= . (current-inexact-milliseconds))) #f] [else ;(define-values (_line1 _col1 pos-before) (port-next-location in)) @@ -509,19 +511,22 @@ added get-regions (define/private (colorer-driver) (unless (andmap lexer-state-up-to-date? lexer-states) (begin-edit-sequence #f #f) + (c-log "starting to color") (define finished? (cond [(and colorer-pending? (= rev (get-revision-number))) (continue-re-tokenize (current-inexact-milliseconds) #f)] [else (start-re-tokenize (current-inexact-milliseconds))])) + (c-log (format "coloring stopped ~a" (if finished? "because it finished" "with more to do"))) (cond [finished? (set! colorer-pending? #f) (for-each (lambda (ls) (set-lexer-state-up-to-date?! ls #t)) lexer-states) - (update-lexer-state-observers)] + (update-lexer-state-observers) + (c-log "updated observers")] [else (set! colorer-pending? #t)]) (end-edit-sequence))) @@ -1141,3 +1146,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)))) From 6cce05a331a7d2409414d9585f02e3631e2cea6d Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 1 Nov 2012 07:34:46 -0500 Subject: [PATCH 12/32] added a script that collects log messages for use in performance debugging drracket original commit: 6f5e43b851b613ec9237e565d69fcb8b17e81870 --- collects/drracket/private/follow-log.rkt | 123 +++++++++++++++++++++++ 1 file changed, 123 insertions(+) create mode 100644 collects/drracket/private/follow-log.rkt diff --git a/collects/drracket/private/follow-log.rkt b/collects/drracket/private/follow-log.rkt new file mode 100644 index 00000000..d9cd5aa1 --- /dev/null +++ b/collects/drracket/private/follow-log.rkt @@ -0,0 +1,123 @@ +#lang racket +(require 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 done-chan (make-channel)) +(void + (thread + (λ () + (let loop ([events '()]) + (sync + (handle-evt + lr + (λ (info) + (loop (cons info events)))) + (handle-evt + done-chan + (λ (resp-chan) + (channel-put resp-chan events)))))))) + +(define f (parameterize ([current-eventspace (make-eventspace)]) + (new frame% [label ""]))) +(define b (new button% [label "Done"] [parent f] + [callback + (λ (_1 _2) + (define resp (make-channel)) + (channel-put done-chan resp) + (show-results (channel-get resp)) + (exit))])) +(send f show #t) + +(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 + (eprintf "unk: ~s\n" x) + 0])) + +(dynamic-require 'drracket #f) From b801edee420c0bc6107b63c0d3edd25c5830b3a8 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 2 Nov 2012 08:16:08 -0500 Subject: [PATCH 13/32] reindent the implementation of open-input-text-editor Apologies for the gratuitious reindent, but I was having a lot of trouble reading this file; it appears to have last been worked on in an Emacs that used tabs for indentation and doesn't use the same tab width as drracket. original commit: 6c760b086fc87163bf3c7086c16efbe845a9b08b --- collects/mred/private/snipfile.rkt | 220 ++++++++++++++--------------- 1 file changed, 110 insertions(+), 110 deletions(-) diff --git a/collects/mred/private/snipfile.rkt b/collects/mred/private/snipfile.rkt index 8f4c91ee..831dd5ea 100644 --- a/collects/mred/private/snipfile.rkt +++ b/collects/mred/private/snipfile.rkt @@ -25,126 +25,126 @@ #: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)]) + (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 (read-bytes-avail!* s pipe-r)] [res (if (eq? v 0) (read-chars s) v)]) (when (eof-object? res) @@ -154,25 +154,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 empty-string)) + port))))))) (define (jump-to-submodule in-port expected-module k) (let ([header (bytes-append #"^#~" From 16d9b00f05871f860d9d7a23f1a3647297c37d6e Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 2 Nov 2012 08:33:40 -0500 Subject: [PATCH 14/32] lift the restriction that the port passed to open-input-text-editor cannot change its revision number during reading This restriction was enforced only for editors that have non string-snip% snips. The restriction was in place because the implementation strategy was to chain thru the snips in the editor using (send snip next) and that isn't safe if the revision number changes. The lifting of the restriction is implemented by tracking the position in the editor where the last snip ended and, if the revision number changes, starting over trying to get a snip from that position. This has the effect that, if the revision number never changes, the code should behave the same as it was doing before (so hopefully any new bugs I've introduced in this commit will only show up if the old implementation would have raised an error) Also, exploit the lifting of this restriction in the colorer so it doesn't to restart the port during to coloring that happens along with the parsing original commit: 95841b9303a753c5b85a929dbfe6167b12407343 --- collects/framework/private/color.rkt | 3 -- collects/mred/private/snipfile.rkt | 32 ++++++++++------ collects/tests/gracket/editor.rktl | 57 ++++++++++++++++++++++++++++ 3 files changed, 77 insertions(+), 15 deletions(-) diff --git a/collects/framework/private/color.rkt b/collects/framework/private/color.rkt index e340683e..ec9a03a9 100644 --- a/collects/framework/private/color.rkt +++ b/collects/framework/private/color.rkt @@ -320,9 +320,6 @@ added get-regions (define re-tokenize-lexer-mode-argument #f) (define/private (continue-re-tokenize start-time did-something?) (cond - [(not (= rev (get-revision-number))) - (c-log "revision number changed unexpectedly") - #f] [(and did-something? ((+ start-time 20) . <= . (current-inexact-milliseconds))) #f] [else diff --git a/collects/mred/private/snipfile.rkt b/collects/mred/private/snipfile.rkt index 831dd5ea..86113ee5 100644 --- a/collects/mred/private/snipfile.rkt +++ b/collects/mred/private/snipfile.rkt @@ -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)) - (set! snip (send-generic snip next-generic)) - (update-str-to-snip 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? @@ -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) diff --git a/collects/tests/gracket/editor.rktl b/collects/tests/gracket/editor.rktl index 41532ae5..d70c33ad 100644 --- a/collects/tests/gracket/editor.rktl +++ b/collects/tests/gracket/editor.rktl @@ -304,6 +304,62 @@ (test #f 'peek-t (peek-byte-or-special i 0)) (test 49 'read-1 (peek-byte-or-special i 1)))) +(let () + (define t (new text%)) + (send t insert "aa\nbb\ncc\ndd\nee\nff\n") + (send t insert (make-object image-snip% + (collection-file-path "recycle.png" "icons"))) + + (define p (open-input-text-editor t)) + + (define rev-at-start (send t get-revision-number)) + (define line1 (read-line p)) + + (define sl (send t get-style-list)) + (define d (make-object style-delta% 'change-bold)) + (define s (send sl find-or-create-style (send sl basic-style) d)) + (send t change-style s 6 7) + + (define rev-after-cs (send t get-revision-number)) + (define line2 (read-line p)) + + (test #t 'revision-changed (> rev-after-cs rev-at-start)) + (test "aa" 'revision-changed-line1 line1) + (test "bb" 'revision-changed-line1 line2)) + +(let () + (define t (new text%)) + (send t insert "abcd\n") + (send t insert (make-object image-snip% + (collection-file-path "recycle.png" "icons"))) + + (define (count-snips) + (let loop ([s (send t find-first-snip)]) + (cond + [s (+ 1 (loop (send s next)))] + [else 0]))) + + (send t split-snip 1) + (define before-snip-count (count-snips)) + (define rev-at-start (send t get-revision-number)) + + (define p (open-input-text-editor t)) + + (define char1 (read-char p)) + + (define s (send (send t get-style-list) basic-style)) + (send t change-style s 0 4) + (define after-snip-count (count-snips)) + (define rev-after-cs (send t get-revision-number)) + + (define chars (string (read-char p) (read-char p) (read-char p))) + + (test 4 'snips-joined1 before-snip-count) + (test 3 'snips-joined2 after-snip-count) + (test #t 'snips-joined3 (> rev-after-cs rev-at-start)) + (test #\a 'snips-joined4 char1) + (test "bcd" 'snips-joined5 chars)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Snips and Streams ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -325,6 +381,7 @@ snip)) (super-instantiate ()))) + (define snip-class (make-object (mk-number-snip-class% #t))) (send snip-class set-classname (format "~s" `(lib "number-snip.ss" "drscheme" "private"))) (send (get-the-snip-class-list) add snip-class) From 4d5c9047784fa83489dc606d6cb4492ad6e72ab2 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 2 Nov 2012 09:59:29 -0500 Subject: [PATCH 15/32] It appears that the colorer was always creating a new port to read from, each time it starts on a new event boundary (this means that in the old (5.3) version of the colorer, it also created a new co-routine on each event boundary! (in other words, most of the reason one would want co-routines here was bogus)) So, refactor the code to just always do this and eliminate a bunch of set!'s and private fields in favor of just passing arguments like sane code does. (We can't eliminate all of that, because we still do need to be able to abort and thus all calls must be tail calls.) original commit: 4ead534227fcbf8e90d0cc5e890f0a67fe6b05cb --- collects/framework/private/color.rkt | 123 ++++++++++++--------------- 1 file changed, 53 insertions(+), 70 deletions(-) diff --git a/collects/framework/private/color.rkt b/collects/framework/private/color.rkt index ec9a03a9..1879642e 100644 --- a/collects/framework/private/color.rkt +++ b/collects/framework/private/color.rkt @@ -236,11 +236,11 @@ added get-regions (start-colorer token-sym->style get-token pairs))) ;; ---------------------- Multi-threading --------------------------- - ;; If there is some incomplete coloring waiting to happen - (define colorer-pending? #f) ;; The editor revision when the last coloring was started - (define rev #f) - + (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 @@ -272,8 +272,7 @@ added get-regions (update-lexer-state-observers) (set! restart-callback #f) (set! force-recolor-after-freeze #f) - (set! colorer-pending? #f) - (set! rev #f)) + (set! revision-when-started-parsing #f)) ;; Discard extra tokens at the first of invalid-tokens (define/private (sync-invalid ls) @@ -290,46 +289,38 @@ added get-regions (set-lexer-state-invalid-tokens-mode! ls mode)) (sync-invalid ls)))) - (define/private (start-re-tokenize start-time) - (set! re-tokenize-lses lexer-states) - (re-tokenize-move-to-next-ls start-time)) - - (define/private (re-tokenize-move-to-next-ls start-time) + (define/private (re-tokenize-move-to-next-ls start-time did-something?) (cond [(null? re-tokenize-lses) ;; done: return #t #t] [else - (set! re-tokenize-ls-argument (car re-tokenize-lses)) + (define ls (car re-tokenize-lses)) (set! re-tokenize-lses (cdr re-tokenize-lses)) - (set! re-tokenize-in-start-pos (lexer-state-current-pos re-tokenize-ls-argument)) - (set! re-tokenize-lexer-mode-argument (lexer-state-current-lexer-mode re-tokenize-ls-argument)) - (set! re-tokenize-in-argument - (open-input-text-editor this - (lexer-state-current-pos re-tokenize-ls-argument) - (lexer-state-end-pos re-tokenize-ls-argument) - (λ (x) #f))) - (port-count-lines! re-tokenize-in-argument) - (set! rev (get-revision-number)) - (continue-re-tokenize start-time #t)])) + (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 re-tokenize-ls-argument #f) - (define re-tokenize-in-argument #f) - (define re-tokenize-in-start-pos #f) - (define re-tokenize-lexer-mode-argument #f) - (define/private (continue-re-tokenize start-time did-something?) + + (define/private (continue-re-tokenize start-time did-something? ls in in-start-pos lexer-mode) (cond - [(and did-something? ((+ start-time 20) . <= . (current-inexact-milliseconds))) + [(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 re-tokenize-in-argument re-tokenize-in-start-pos re-tokenize-lexer-mode-argument)) + (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)] + (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)) @@ -337,10 +328,10 @@ added get-regions (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)) - #; (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)) @@ -348,34 +339,33 @@ added get-regions ;; 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! re-tokenize-ls-argument (+ len (lexer-state-current-pos re-tokenize-ls-argument))) - (set-lexer-state-current-lexer-mode! re-tokenize-ls-argument new-lexer-mode) - (sync-invalid re-tokenize-ls-argument) + (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 re-tokenize-in-start-pos new-token-start new-token-end)) + (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 re-tokenize-ls-argument) len (make-data type new-lexer-mode backup-delta)) + (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 re-tokenize-ls-argument) add-token data len) + (send (lexer-state-parens ls) add-token data len) (cond - [(and (not (send (lexer-state-invalid-tokens re-tokenize-ls-argument) is-empty?)) - (= (lexer-state-invalid-tokens-start re-tokenize-ls-argument) - (lexer-state-current-pos re-tokenize-ls-argument)) + [(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 re-tokenize-ls-argument))) - (send (lexer-state-invalid-tokens re-tokenize-ls-argument) search-max!) - (send (lexer-state-parens re-tokenize-ls-argument) merge-tree - (send (lexer-state-invalid-tokens re-tokenize-ls-argument) get-root-end-position)) - (insert-last! (lexer-state-tokens re-tokenize-ls-argument) - (lexer-state-invalid-tokens re-tokenize-ls-argument)) - (set-lexer-state-invalid-tokens-start! re-tokenize-ls-argument +inf.0) - (re-tokenize-move-to-next-ls start-time)] + (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 - (set! re-tokenize-lexer-mode-argument new-lexer-mode) - (continue-re-tokenize start-time #t)]))])])) + (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))) @@ -509,24 +499,17 @@ added get-regions (unless (andmap lexer-state-up-to-date? lexer-states) (begin-edit-sequence #f #f) (c-log "starting to color") - (define finished? - (cond - [(and colorer-pending? (= rev (get-revision-number))) - (continue-re-tokenize (current-inexact-milliseconds) #f)] - [else - (start-re-tokenize (current-inexact-milliseconds))])) + (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"))) - (cond - [finished? - (set! colorer-pending? #f) - (for-each (lambda (ls) - (set-lexer-state-up-to-date?! ls #t)) - lexer-states) - (update-lexer-state-observers) - (c-log "updated observers")] - [else - (set! colorer-pending? #t)]) - (end-edit-sequence))) + (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) + (c-log "finished end-edit-sequence"))) (define/private (colorer-callback) (cond From d4ac5ab68380bba8dea18c3d7fcc2a3cc37b5603 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Fri, 2 Nov 2012 18:16:56 -0400 Subject: [PATCH 16/32] Fix typo Closes PR 13158 original commit: 4948ca0863a26f9b1ab68ad2a5e606a8c7f538b2 --- collects/scribblings/gui/menu-item-intf.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribblings/gui/menu-item-intf.scrbl b/collects/scribblings/gui/menu-item-intf.scrbl index 68256560..7f86372a 100644 --- a/collects/scribblings/gui/menu-item-intf.scrbl +++ b/collects/scribblings/gui/menu-item-intf.scrbl @@ -10,7 +10,7 @@ A @racket[menu-item<%>] object is an element within a @racket[menu%], @racket[menu-item<%>] object. A menu item is either a @racket[separator-menu-item%] object (merely - a separator), of a @racket[labelled-menu-item<%>] object; the latter + a separator), or a @racket[labelled-menu-item<%>] object; the latter is more specifically an instance of either @racket[menu-item%] (a plain menu item), @racket[checkable-menu-item%] (a checkable menu item), or @racket[menu%] (a submenu). From 274cce043960a51b5b77c4648a7124b2bfdd70c3 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 2 Nov 2012 19:37:42 -0500 Subject: [PATCH 17/32] make popup menus respond to mouse-up events, not mouse-down ones original commit: 0377bda9474f8848a97509ace898174c83361006 --- collects/framework/private/keymap.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/framework/private/keymap.rkt b/collects/framework/private/keymap.rkt index 4c9fdd0e..6556aa5f 100644 --- a/collects/framework/private/keymap.rkt +++ b/collects/framework/private/keymap.rkt @@ -337,7 +337,7 @@ [mouse-popup-menu (λ (edit event) - (when (send event button-down?) + (when (send event button-up?) (let ([a (send edit get-admin)]) (when a (let ([m (make-object popup-menu%)]) From 6706264ae8c540a95590d7268b750f5166dc45fe Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 3 Nov 2012 10:19:59 -0500 Subject: [PATCH 18/32] fix test so that labels can be regexps (as was already documented) and tidy up framework/test docs original commit: c375042f10fc1440fb56a2ef867f42e24f16bb39 --- collects/framework/test.rkt | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) diff --git a/collects/framework/test.rkt b/collects/framework/test.rkt index 87845539..1f64b784 100644 --- a/collects/framework/test.rkt +++ b/collects/framework/test.rkt @@ -253,22 +253,26 @@ (define object-tag 'test:find-object) -;; find-object : class (union string (object -> boolean)) -> object +;; find-object : class (union string regexp (object -> boolean)) -> object (define (find-object obj-class b-desc) (λ () (cond [(or (string? b-desc) + (regexp? b-desc) (procedure? b-desc)) (let* ([active-frame (test:get-active-top-level-window)] [_ (unless active-frame (error object-tag - "could not find object: ~a, no active frame" + "could not find object: ~e, no active frame" b-desc))] [child-matches? (λ (child) (cond [(string? b-desc) (equal? (send child get-label) b-desc)] + [(regexp? b-desc) + (and (send child get-label) + (regexp-match? b-desc (send child get-label)))] [(procedure? b-desc) (b-desc child)]))] [found @@ -287,13 +291,13 @@ (send panel get-children)))]) (or found (error object-tag - "no object of class ~a named ~e in active frame" + "no object of class ~e named ~e in active frame" obj-class b-desc)))] [(is-a? b-desc obj-class) b-desc] [else (error object-tag - "expected either a string or an object of class ~a as input, received: ~a" + "expected either a string or an object of class ~e as input, received: ~e" obj-class b-desc)]))) @@ -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 From 49889e566b5773bbcceaaffd1fbd3400161fb424 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 3 Nov 2012 10:20:36 -0500 Subject: [PATCH 19/32] add find-labelled-windows original commit: e1760fa7c0690697a97343faf3d4991990c19c91 --- collects/tests/utils/gui.rkt | 119 ++++++++++++++++++----------------- 1 file changed, 63 insertions(+), 56 deletions(-) diff --git a/collects/tests/utils/gui.rkt b/collects/tests/utils/gui.rkt index 069e29d3..b4709ac1 100644 --- a/collects/tests/utils/gui.rkt +++ b/collects/tests/utils/gui.rkt @@ -1,8 +1,10 @@ -(module gui mzscheme - (require mred - mzlib/class - mzlib/etc) - (provide find-labelled-window whitespace-string=?) +#lang racket/base + + (require racket/gui/base + racket/class) + (provide find-labelled-window + find-labelled-windows + whitespace-string=?) ;; whitespace-string=? : string string -> boolean ;; determines if two strings are equal, up to their whitespace. @@ -60,59 +62,64 @@ [else #f]))) ;; whitespace-string=? tests - '(map (lambda (x) (apply equal? x)) - (list (list #t (whitespace-string=? "a" "a")) - (list #f (whitespace-string=? "a" "A")) - (list #f (whitespace-string=? "a" " ")) - (list #f (whitespace-string=? " " "A")) - (list #t (whitespace-string=? " " " ")) - (list #t (whitespace-string=? " " " ")) - (list #t (whitespace-string=? " " " ")) - (list #t (whitespace-string=? " " " ")) - (list #t (whitespace-string=? "a a" "a a")) - (list #t (whitespace-string=? "a a" "a a")) - (list #t (whitespace-string=? "a a" "a a")) - (list #t (whitespace-string=? " a" "a")) - (list #t (whitespace-string=? "a" " a")) - (list #t (whitespace-string=? "a " "a")) - (list #t (whitespace-string=? "a" "a ")))) + (module+ test + (require rackunit) + (check-equal? #t (whitespace-string=? "a" "a")) + (check-equal? #f (whitespace-string=? "a" "A")) + (check-equal? #f (whitespace-string=? "a" " ")) + (check-equal? #f (whitespace-string=? " " "A")) + (check-equal? #t (whitespace-string=? " " " ")) + (check-equal? #t (whitespace-string=? " " " ")) + (check-equal? #t (whitespace-string=? " " " ")) + (check-equal? #t (whitespace-string=? " " " ")) + (check-equal? #t (whitespace-string=? "a a" "a a")) + (check-equal? #t (whitespace-string=? "a a" "a a")) + (check-equal? #t (whitespace-string=? "a a" "a a")) + (check-equal? #t (whitespace-string=? " a" "a")) + (check-equal? #t (whitespace-string=? "a" " a")) + (check-equal? #t (whitespace-string=? "a " "a")) + (check-equal? #t (whitespace-string=? "a" "a "))) ;;; find-labelled-window : (union ((union #f string) -> window<%>) ;;; ((union #f string) (union #f class) -> window<%>) ;;; ((union #f string) (union class #f) area-container<%> -> window<%>)) ;;;; may call error, if no control with the label is found - (define find-labelled-window - (opt-lambda (label - [class #f] - [window (get-top-level-focus-window)] - [failure (lambda () - (error 'find-labelled-window "no window labelled ~e in ~e~a" - label - window - (if class - (format " matching class ~e" class) - "")))]) - (unless (or (not label) - (string? label)) - (error 'find-labelled-window "first argument must be a string or #f, got ~e; other args: ~e ~e" - label class window)) - (unless (or (class? class) - (not class)) - (error 'find-labelled-window "second argument must be a class or #f, got ~e; other args: ~e ~e" - class label window)) - (unless (is-a? window area-container<%>) - (error 'find-labelled-window "third argument must be a area-container<%>, got ~e; other args: ~e ~e" - window label class)) - (let ([ans - (let loop ([window window]) - (cond - [(and (or (not class) - (is-a? window class)) - (let ([win-label (and (is-a? window window<%>) - (send window get-label))]) - (equal? label win-label))) - window] - [(is-a? window area-container<%>) (ormap loop (send window get-children))] - [else #f]))]) - (or ans - (failure)))))) + (define (find-labelled-window label + [class #f] + [window (get-top-level-focus-window)] + [failure (λ () + (error 'find-labelled-window "no window labelled ~e in ~e~a" + label + window + (if class + (format " matching class ~e" class) + "")))]) + (define windows (find-labelled-windows label class window)) + (cond + [(null? windows) (failure)] + [else (car windows)])) + + (define (find-labelled-windows label [class #f] [window (get-top-level-focus-window)]) + (unless (or (not label) + (string? label)) + (error 'find-labelled-windows "first argument must be a string or #f, got ~e; other args: ~e ~e" + label class window)) + (unless (or (class? class) + (not class)) + (error 'find-labelled-windows "second argument must be a class or #f, got ~e; other args: ~e ~e" + class label window)) + (unless (is-a? window area-container<%>) + (error 'find-labelled-windows "third argument must be a area-container<%>, got ~e; other args: ~e ~e" + window label class)) + (let loop ([window window]) + (cond + [(and (or (not class) + (is-a? window class)) + (let ([win-label (and (is-a? window window<%>) + (send window get-label))]) + (equal? label win-label))) + (list window)] + [(is-a? window area-container<%>) (apply append (map loop (send window get-children)))] + [else '()]))) + + From c08ebddadb77f4658b28aa7246b45977b6060d30 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 2 Nov 2012 15:17:16 -0600 Subject: [PATCH 20/32] error message repair original commit: ad703025c5d2c0d254f708bad9e854ce4894907b --- collects/mred/private/mrmenu.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mred/private/mrmenu.rkt b/collects/mred/private/mrmenu.rkt index 4523958c..967c7cf7 100644 --- a/collects/mred/private/mrmenu.rkt +++ b/collects/mred/private/mrmenu.rkt @@ -465,6 +465,6 @@ (define (menu-or-bar-parent who p) (unless (or (is-a? p internal-menu<%>) (is-a? p menu-bar%)) (unless (is-a? p menu-item-container<%>) - (raise-arguments-error (constructor-name who) "(is-a?/c menu-item-container<%>)" p)) + (raise-argument-error (constructor-name who) "(is-a?/c menu-item-container<%>)" p)) (raise-arguments-error (who->name who) "invalid parent;\n given parent is not an instance of a built-in menu item container class" "given parent" p))) From 94dea090486c2a39b093a677bb975f9baa3dd7e6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 4 Nov 2012 07:36:36 -0700 Subject: [PATCH 21/32] racket/gui: add `delete' to `choice%' and `list-control<%>' Closes PR 13230 original commit: 0c82f54912a2a2d3e087ab8c8a533b42008d6080 --- collects/mred/private/mritem.rkt | 11 +++++------ collects/mred/private/wx/cocoa/choice.rkt | 2 ++ collects/mred/private/wx/gtk/choice.rkt | 8 +++++++- collects/mred/private/wx/win32/choice.rkt | 8 ++++---- collects/mred/private/wx/win32/const.rkt | 1 + collects/mred/private/wxlitem.rkt | 3 ++- collects/scribblings/gui/list-box-class.scrbl | 10 ---------- .../scribblings/gui/list-control-intf.scrbl | 19 +++++++++++++++---- collects/tests/gracket/item.rkt | 12 +++++------- 9 files changed, 41 insertions(+), 33 deletions(-) diff --git a/collects/mred/private/mritem.rkt b/collects/mred/private/mritem.rkt index 78108061..76cb3b57 100644 --- a/collects/mred/private/mritem.rkt +++ b/collects/mred/private/mritem.rkt @@ -600,7 +600,10 @@ [find-string (entry-point (lambda (x) (check-label-string '(method list-control<%> find-string) x) (do-find-string x)))] - + [delete (entry-point (lambda (n) + (check-item 'delete n) + (send this -delete-list-item n) + (send wx delete n)))] [-append-list-string (lambda (i) (set! content (append content (list i))))] [-set-list-string (lambda (i s) @@ -842,11 +845,7 @@ (set! num-columns (add1 num-columns)) (set! column-labels (append column-labels (list label))) (send wx append-column label))))] - - [delete (entry-point (lambda (n) - (check-item 'delete n) - (send this -delete-list-item n) - (send wx delete n)))] + [get-data (entry-point (lambda (n) (check-item 'get-data n) (send wx get-data n)))] [get-label-font (lambda () (send wx get-label-font))] [get-selections (entry-point (lambda () (send wx get-selections)))] diff --git a/collects/mred/private/wx/cocoa/choice.rkt b/collects/mred/private/wx/cocoa/choice.rkt index c174789d..c15b724f 100644 --- a/collects/mred/private/wx/cocoa/choice.rkt +++ b/collects/mred/private/wx/cocoa/choice.rkt @@ -68,6 +68,8 @@ (tellv (get-cocoa) insertItemWithTitle: #:type _NSString lbl atIndex: #:type _NSInteger (number))) + (define/public (delete i) + (tellv (get-cocoa) removeItemAtIndex: #:type _NSInteger i)) (define/override (maybe-register-as-child parent on?) (register-as-child parent on?))) diff --git a/collects/mred/private/wx/gtk/choice.rkt b/collects/mred/private/wx/gtk/choice.rkt index 39802d2c..b5c9d9ef 100644 --- a/collects/mred/private/wx/gtk/choice.rkt +++ b/collects/mred/private/wx/gtk/choice.rkt @@ -78,9 +78,12 @@ (set! ignore-clicked? #t) (gtk_combo_box_set_active gtk i) (set! ignore-clicked? #f))) + (define/public (get-selection) (gtk_combo_box_get_active gtk)) + (define/public (number) count) + (define/public (clear) (atomically (set! ignore-clicked? #t) @@ -88,6 +91,7 @@ (gtk_combo_box_remove_text gtk 0)) (set! count 0) (set! ignore-clicked? #f))) + (public [-append append]) (define (-append l) (atomically @@ -96,5 +100,7 @@ (gtk_combo_box_append_text gtk l) (when (= count 1) (set-selection 0)) - (set! ignore-clicked? #f)))) + (set! ignore-clicked? #f))) + (define/public (delete i) + (gtk_combo_box_remove_text gtk i))) diff --git a/collects/mred/private/wx/win32/choice.rkt b/collects/mred/private/wx/win32/choice.rkt index 74a4c9d2..b14ecb91 100644 --- a/collects/mred/private/wx/win32/choice.rkt +++ b/collects/mred/private/wx/win32/choice.rkt @@ -102,13 +102,13 @@ (SendMessageW hwnd CB_RESETCONTENT 0 0) (set! num-choices 0))) - (public [append* append]) (define (append* str) (atomically (SendMessageW/str hwnd CB_ADDSTRING 0 str) (set! num-choices (add1 num-choices)) - (when (= 1 num-choices) (set-selection 0)))))) - - + (when (= 1 num-choices) (set-selection 0)))) + (define/public (delete i) + (set! num-choices (sub1 num-choices)) + (void (SendMessageW hwnd CB_DELETESTRING i 0))))) diff --git a/collects/mred/private/wx/win32/const.rkt b/collects/mred/private/wx/win32/const.rkt index 7b96f9f6..0ace67bf 100644 --- a/collects/mred/private/wx/win32/const.rkt +++ b/collects/mred/private/wx/win32/const.rkt @@ -617,6 +617,7 @@ (define CB_SETCURSEL #x014E) (define CB_GETCURSEL #x0147) (define CB_ADDSTRING #x0143) +(define CB_DELETESTRING #x0144) (define CB_RESETCONTENT #x014B) (define CBN_SELENDOK 9) diff --git a/collects/mred/private/wxlitem.rkt b/collects/mred/private/wxlitem.rkt index fa55722d..b85f75f4 100644 --- a/collects/mred/private/wxlitem.rkt +++ b/collects/mred/private/wxlitem.rkt @@ -113,7 +113,8 @@ (get-selection) (number) (clear) - (append lbl)) + (append lbl) + (delete i)) (stretchable-in-y #f) (stretchable-in-x #f))) diff --git a/collects/scribblings/gui/list-box-class.scrbl b/collects/scribblings/gui/list-box-class.scrbl index 7506d859..1c5d438c 100644 --- a/collects/scribblings/gui/list-box-class.scrbl +++ b/collects/scribblings/gui/list-box-class.scrbl @@ -157,16 +157,6 @@ style. The new column is logically the last column, and it is initially displayed as the last column.} -@defmethod[(delete [n exact-nonnegative-integer?]) - void?]{ - -Deletes the item indexed by @racket[n]. @|lbnumnote| If @racket[n] is equal - to or larger than the number of items in the control, @|MismatchExn|. - -Selected items that are not deleted remain selected, and no other - items are selected.} - - @defmethod[(delete-column [n exact-nonnegative-integer?]) void?]{ diff --git a/collects/scribblings/gui/list-control-intf.scrbl b/collects/scribblings/gui/list-control-intf.scrbl index 3c035271..4b04a930 100644 --- a/collects/scribblings/gui/list-control-intf.scrbl +++ b/collects/scribblings/gui/list-control-intf.scrbl @@ -36,11 +36,22 @@ Removes all user-selectable items from the control. } +@defmethod[(delete [n exact-nonnegative-integer?]) + void?]{ + +Deletes the item indexed by @racket[n] (where items are indexed + from @racket[0]). If @racket[n] is equal + to or larger than the number of items in the control, @|MismatchExn|. + +Selected items that are not deleted remain selected, and no other + items are selected.} + + @defmethod[(find-string [s string?]) (or/c exact-nonnegative-integer? #f)]{ Finds a user-selectable item matching the given string. If no matching choice is found, @racket[#f] is returned, otherwise the index of the - matching choice is returned (items are indexed from @racket[0]). + matching choice is returned (where items are indexed from @racket[0]). } @@ -53,7 +64,7 @@ Returns the number of user-selectable items in the control (which is @defmethod[(get-selection) (or/c exact-nonnegative-integer? #f)]{ -Returns the index of the currently selected item (items are indexed +Returns the index of the currently selected item (where items are indexed from @racket[0]). If the choice item currently contains no choices or no selections, @racket[#f] is returned. If multiple selections are allowed and multiple items are selected, the index of the first @@ -64,7 +75,7 @@ Returns the index of the currently selected item (items are indexed @defmethod[(get-string [n exact-nonnegative-integer?]) (and/c immutable? label-string?)]{ -Returns the item for the given index (items are indexed from +Returns the item for the given index (where items are indexed from @racket[0]). If the provided index is larger than the greatest index in the list control, @|MismatchExn|. @@ -81,7 +92,7 @@ Returns the currently selected item. If the control currently @defmethod[(set-selection [n exact-nonnegative-integer?]) void?]{ -Selects the item specified by the given index (items are indexed from +Selects the item specified by the given index (where items are indexed from @racket[0]). If the given index larger than the greatest index in the list control, @|MismatchExn|. diff --git a/collects/tests/gracket/item.rkt b/collects/tests/gracket/item.rkt index 7c3da066..8566a951 100644 --- a/collects/tests/gracket/item.rkt +++ b/collects/tests/gracket/item.rkt @@ -1556,13 +1556,11 @@ (when (<= 0 p (sub1 (length actual-content))) (set! actual-content (gone actual-content p)) (set! actual-user-data (gone actual-user-data p)))) - (define db (if list? - (make-object button% - "Delete" cdp - (lambda (b e) - (let ([p (send c get-selection)]) - (delete p)))) - null)) + (define db (make-object button% + "Delete" cdp + (lambda (b e) + (let ([p (send c get-selection)]) + (delete p))))) (define dab (if list? (make-object button% "Delete Above" cdp From 0dff615872fe53212b49da17cba635a0fb380097 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 4 Nov 2012 08:26:32 -0700 Subject: [PATCH 22/32] racket/gui: fix problems with control labels and client/global positions Closes PR 13232 original commit: 068240e9fefd7bfe7dbbbc9b3cad98bc191ee78a --- collects/mred/private/wx/cocoa/window.rkt | 21 +++++- collects/mred/private/wx/gtk/frame.rkt | 2 +- collects/mred/private/wx/gtk/window.rkt | 83 ++++++++++++++--------- collects/mred/private/wx/win32/window.rkt | 22 +++++- collects/mred/private/wxlitem.rkt | 14 +++- collects/mred/private/wxpanel.rkt | 1 + 6 files changed, 106 insertions(+), 37 deletions(-) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index ed1b1dcd..ff0a22cd 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -604,6 +604,10 @@ (- y (client-y-offset)))))) (define/public (client-y-offset) 0) + (define event-position-wrt-wx #f) + (define/public (set-event-positions-wrt wx) + (set! event-position-wrt-wx wx)) + (define/public (is-view?) #t) (define/public (window-point-to-view pos) (let ([pos (if (is-view?) @@ -611,8 +615,17 @@ convertPoint: #:type _NSPoint pos fromView: #f) pos)]) - (values (NSPoint-x pos) - (flip-client (NSPoint-y pos))))) + (define x (NSPoint-x pos)) + (define y (flip-client (NSPoint-y pos))) + (cond + [event-position-wrt-wx + (define xb (box (->long x))) + (define yb (box (->long y))) + (internal-client-to-screen xb yb) + (send event-position-wrt-wx internal-screen-to-client xb yb) + (values (unbox xb) (unbox yb))] + [else (values x y)]))) + (define/public (get-x) (->long (NSPoint-x (NSRect-origin (get-frame))))) @@ -799,6 +812,8 @@ (define/public (refresh-all-children) (void)) (define/public (screen-to-client xb yb) + (internal-screen-to-client xb yb)) + (define/public (internal-screen-to-client xb yb) (let ([p (tell #:type _NSPoint (get-cocoa-content) convertPoint: #:type _NSPoint (tell #:type _NSPoint (get-cocoa-window) @@ -810,6 +825,8 @@ (set-box! yb (inexact->exact (floor (flip-client (NSPoint-y p))))))) (define/public (client-to-screen xb yb [flip-y? #t]) + (internal-client-to-screen xb yb flip-y?)) + (define/public (internal-client-to-screen xb yb [flip-y? #t]) (let* ([p (tell #:type _NSPoint (get-cocoa-window) convertBaseToScreen: #:type _NSPoint diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index fc041d70..d46279c9 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -424,7 +424,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)]) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 643f5a13..216d5461 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -345,35 +345,39 @@ [(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)])]) + [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 () @@ -697,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)) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 23d0f506..6e3979a5 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -412,12 +412,29 @@ (define/public (on-resized) (void)) + (define event-position-wrt-wx #f) + (define/public (set-event-positions-wrt wx) + (set! event-position-wrt-wx wx)) + + (define/private (adjust-event-position x y) + (if event-position-wrt-wx + (let ([xb (box x)] + [yb (box y)]) + (internal-client-to-screen xb yb) + (send event-position-wrt-wx internal-screen-to-client xb yb) + (values (unbox xb) (unbox yb))) + (values x y))) + (define/public (screen-to-client x y) + (internal-screen-to-client x y)) + (define/public (internal-screen-to-client x y) (let ([p (make-POINT (unbox x) (unbox y))]) (ScreenToClient (get-client-hwnd) p) (set-box! x (POINT-x p)) (set-box! y (POINT-y p)))) (define/public (client-to-screen x y) + (internal-client-to-screen x y)) + (define/public (internal-client-to-screen x y) (let ([p (make-POINT (unbox x) (unbox y))]) (ClientToScreen (get-client-hwnd) p) (set-box! x (POINT-x p)) @@ -607,6 +624,7 @@ [bit? (lambda (v b) (not (zero? (bitwise-and v b))))]) (let ([make-e (lambda (type) + (define-values (mx my) (adjust-event-position x y)) (new mouse-event% [event-type type] [left-down (case type @@ -621,8 +639,8 @@ [(right-down) #t] [(right-up) #f] [else (bit? flags MK_RBUTTON)])] - [x x] - [y y] + [x mx] + [y my] [shift-down (bit? flags MK_SHIFT)] [control-down (bit? flags MK_CONTROL)] [meta-down #f] diff --git a/collects/mred/private/wxlitem.rkt b/collects/mred/private/wxlitem.rkt index b85f75f4..a32d650c 100644 --- a/collects/mred/private/wxlitem.rkt +++ b/collects/mred/private/wxlitem.rkt @@ -59,7 +59,7 @@ (define wx-label-panel% (class wx-control-horizontal-panel% (init proxy parent label style font halign valign) - (inherit area-parent skip-enter-leave-events) + (inherit area-parent skip-enter-leave-events set-event-positions-wrt) (define c #f) (define/override (enable on?) (if c (send c enable on?) (void))) @@ -77,9 +77,21 @@ (define/public (set-label s) (when l (send l set-label s))) (define/public (get-label) (and l (send l get-label))) + (define/override (client-to-screen x y) + (if c + (send c client-to-screen x y) + (super client-to-screen x y))) + (define/override (screen-to-client x y) + (if c + (send c screen-to-client x y) + (super screen-to-client x y))) + (define/public (get-p) p) (define/public (set-c v sx? sy?) (set! c v) + (set-event-positions-wrt c) + (when l (send l set-event-positions-wrt c)) + (when p (send p set-event-positions-wrt c)) (send c stretchable-in-x sx?) (send c stretchable-in-y sy?) (send c skip-subwindow-events? #t)))) diff --git a/collects/mred/private/wxpanel.rkt b/collects/mred/private/wxpanel.rkt index c7e279cf..471fe6c9 100644 --- a/collects/mred/private/wxpanel.rkt +++ b/collects/mred/private/wxpanel.rkt @@ -54,6 +54,7 @@ (unless (negative? h) (set! height h)))] [get-x (lambda () pos-x)] [get-y (lambda () pos-y)] + [set-event-positions-wrt (lambda (c) (void))] [get-width (lambda () width)] [get-height (lambda () height)] [adopt-child (lambda (c) (send (get-parent) adopt-child c))]) From 1d775e0b5796087e9dc19582f177406f650a3851 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 4 Nov 2012 14:36:48 -0600 Subject: [PATCH 23/32] adjust log following to make it work for the middle of a drracket editing session original commit: ef3eb3154aa21d83c100d7664121c92eba174959 --- collects/drracket/private/follow-log.rkt | 55 ++++++++++++++++-------- 1 file changed, 38 insertions(+), 17 deletions(-) diff --git a/collects/drracket/private/follow-log.rkt b/collects/drracket/private/follow-log.rkt index d9cd5aa1..f834e98e 100644 --- a/collects/drracket/private/follow-log.rkt +++ b/collects/drracket/private/follow-log.rkt @@ -18,6 +18,7 @@ log message was reported. |# + (define lr (make-log-receiver (current-logger) 'debug 'racket/engine 'debug 'GC @@ -27,31 +28,46 @@ log message was reported. (define top-n-events 50) (define drop-gc? #t) +(define start-right-away? #f) (define done-chan (make-channel)) +(define start-chan (make-channel)) (void (thread (λ () - (let loop ([events '()]) - (sync - (handle-evt - lr - (λ (info) - (loop (cons info events)))) - (handle-evt - done-chan - (λ (resp-chan) - (channel-put resp-chan events)))))))) + (let loop () + (sync start-chan) + (let loop ([events '()]) + (sync + (handle-evt + lr + (λ (info) + (loop (cons info events)))) + (handle-evt + done-chan + (λ (resp-chan) + (channel-put resp-chan events))))) + (loop))))) -(define f (parameterize ([current-eventspace (make-eventspace)]) +(define controller-frame-eventspace (make-eventspace)) +(define f (parameterize ([current-eventspace controller-frame-eventspace]) (new frame% [label ""]))) -(define b (new button% [label "Done"] [parent f] +(define sb (new button% [label "Start"] [parent f] [callback (λ (_1 _2) - (define resp (make-channel)) - (channel-put done-chan resp) - (show-results (channel-get resp)) - (exit))])) + (sb-callback))])) +(define db (new button% [label "Stop && Dump"] [parent f] [enabled #f] + [callback + (λ (_1 _2) + (define resp (make-channel)) + (channel-put done-chan resp) + (show-results (channel-get resp)) + (send db enable #f) + (send sb enable #t))])) +(define (sb-callback) + (send sb enable #f) + (send db enable #t) + (channel-put start-chan #t)) (send f show #t) (struct gui-event (start end name) #:prefab) @@ -117,7 +133,12 @@ log message was reported. [(timeline-info? (vector-ref x 2)) (timeline-info-milliseconds (vector-ref x 2))] [else - (eprintf "unk: ~s\n" x) + (unless (regexp-match #rx"^GC: 0:MST @" (vector-ref x 1)) + (eprintf "unk: ~s\n" x)) 0])) + +(when start-right-away? + (parameterize ([current-eventspace controller-frame-eventspace]) + (queue-callback sb-callback))) (dynamic-require 'drracket #f) From 14747de35e012117baf1b6c18fece2d958f3cdbf Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 4 Nov 2012 19:01:24 -0600 Subject: [PATCH 24/32] audit the calls to invalidate-bitmap-cache in the framework and in drracket and try to make them happen less often (or, if there will be multiple ones, try to guarantee that there is an edit sequence) original commit: 81dc3bae37690e066204051b8b32d7db16ce4a67 --- collects/framework/private/text.rkt | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index d66f8579..0ed33675 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -3855,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 @@ -4194,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))) @@ -4209,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))) From 80ea492441a1986b5b9f54191a8b1a36e8beb119 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 5 Nov 2012 09:17:18 -0600 Subject: [PATCH 25/32] clarify the way the undoable? flag in begin-edit-sequence works original commit: f311676096bbcb216c0a601ba0191c3391defb8b --- collects/scribblings/gui/editor-intf.scrbl | 53 +++++++++++++++++++++- 1 file changed, 51 insertions(+), 2 deletions(-) diff --git a/collects/scribblings/gui/editor-intf.scrbl b/collects/scribblings/gui/editor-intf.scrbl index 4555fda0..7f16be31 100644 --- a/collects/scribblings/gui/editor-intf.scrbl +++ b/collects/scribblings/gui/editor-intf.scrbl @@ -1,5 +1,9 @@ #lang scribble/doc -@(require "common.rkt") +@(require "common.rkt" + scribble/eval) + +@(define editor-eval (make-base-eval)) +@(editor-eval '(require racket/class)) @definterface/title[editor<%> ()]{ @@ -206,7 +210,52 @@ See also @method[editor<%> refresh-delayed?] and @method[editor<%> If the @racket[undoable?] flag is @racket[#f], then the changes made in the sequence cannot be reversed through the @method[editor<%> - undo] method. This flag is only effective for the outermost + undo] method. To accomplish this, the editor just does not add + entries to the undo log when in an edit sequence where the + @racket[undoable?] flag is @racket[#f]. So, for example, if an + @litchar{a} is inserted into the editor and then a @litchar{b} + is inserted, and then an un-undoable edit-sequence begins, + and the @litchar{a} is colored red, and then the edit-sequence ends, + then an undo will remove the @litchar{b}, leaving the @litchar{a} + colored red. + + This behavior also means that editors can get confused. Consider + this program: + @examples[#:eval + editor-eval + (eval:alts (define t (new text%)) + ;; this is a pretty horrible hack, but + ;; the sequence of calls below behaves + ;; the way they are predicted to as of + ;; the moment of this commit + (define t + (new (class object% + (define/public (set-max-undo-history x) (void)) + (define/public (insert . args) (void)) + (define/public (begin-edit-sequence a b) (void)) + (define/public (end-edit-sequence) (void)) + (define/public (undo) (void)) + (define first? #t) + (define/public (get-text) + (cond + [first? + (set! first? #f) + "cab"] + [else "cb"])) + (super-new))))) + (send t set-max-undo-history 'forever) + (send t insert "a") + (send t insert "b") + (send t begin-edit-sequence #f #f) + (send t insert "c" 0 0) + (send t end-edit-sequence) + (send t get-text) + (send t undo) + (send t get-text)] + You might hope that the undo would remove the @litchar{b}, but it removes + the @litchar{a}. + + The @racket[undoable?] flag is only effective for the outermost @method[editor<%> begin-edit-sequence] when nested sequences are used. Note that, for a @racket[text%] object, the character-inserting version of @method[text% insert] interferes with sequence-based undo From fa9becf12f9199be8a60841773fbf89435b0dc72 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 6 Nov 2012 14:47:08 -0500 Subject: [PATCH 26/32] Some more `#lang racket' -> `#lang racket/base' conversions (And some other related minor racketisms.) original commit: 39a0ab60a78d6d60e8c20450f10b273261c0d325 --- collects/mrlib/private/regmk.rkt | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/collects/mrlib/private/regmk.rkt b/collects/mrlib/private/regmk.rkt index bf5d8bf1..a6401351 100644 --- a/collects/mrlib/private/regmk.rkt +++ b/collects/mrlib/private/regmk.rkt @@ -1,6 +1,9 @@ -#lang racket +#lang racket/base + +(require (for-syntax racket/base)) + (provide define-struct/reg-mk - id->constructor + id->constructor (struct-out point) (struct-out bb)) From ab6d9e07627401479f59045025ef51a28f24989c Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 6 Nov 2012 15:07:09 -0500 Subject: [PATCH 27/32] `#lang racket' -> `#lang racket/base' conversions in drracket and in redex. original commit: 26045a27fb1f1faeb8c9ba1208366e6c519fba52 --- collects/drracket/private/follow-log.rkt | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/collects/drracket/private/follow-log.rkt b/collects/drracket/private/follow-log.rkt index f834e98e..bc3f52ef 100644 --- a/collects/drracket/private/follow-log.rkt +++ b/collects/drracket/private/follow-log.rkt @@ -1,5 +1,10 @@ -#lang racket -(require racket/gui/base +#lang racket/base + +(require racket/list + racket/class + racket/match + racket/pretty + racket/gui/base framework/private/logging-timer) #| From 5b1e17cc7cd39d59043db80a9302021110f61f7a Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 7 Nov 2012 10:42:42 -0500 Subject: [PATCH 28/32] Lots of bad TAB eliminations. I started from tabs that are not on the beginning of lines, and in several places I did further cleanings. If you're worried about knowing who wrote some code, for example, if you get to this commit in "git blame", then note that you can use the "-w" flag in many git commands to ignore whitespaces. For example, to see per-line authors, use "git blame -w ". Another example: to see the (*much* smaller) non-whitespace changes in this (or any other) commit, use "git log -p -w -1 ". original commit: 672910f27b856549ad08d38832b6714edf226c8e --- collects/framework/private/keymap.rkt | 4 +- collects/framework/private/racket.rkt | 2 +- collects/framework/test.rkt | 2 +- collects/mred/private/moredialogs.rkt | 2 +- collects/mred/private/mrcanvas.rkt | 7 +- collects/mred/private/wx/gtk/types.rkt | 22 +- collects/mred/private/wx/gtk/window.rkt | 264 +++++++-------- collects/mred/private/wx/win32/types.rkt | 46 +-- .../mrlib/scribblings/switchable-button.scrbl | 2 +- collects/scribblings/framework/splash.scrbl | 2 +- collects/tests/gracket/mem.rkt | 319 +++++++++--------- 11 files changed, 336 insertions(+), 336 deletions(-) diff --git a/collects/framework/private/keymap.rkt b/collects/framework/private/keymap.rkt index 6556aa5f..21042cda 100644 --- a/collects/framework/private/keymap.rkt +++ b/collects/framework/private/keymap.rkt @@ -739,7 +739,7 @@ (send edit on-char event) (loop (sub1 n))))) (λ () - (send edit end-edit-sequence))))))) + (send edit end-edit-sequence))))))) #t)) (send km set-break-sequence-callback done) #t))] @@ -823,7 +823,7 @@ (λ (edit event) (when building-macro (set! current-macro (reverse building-macro)) - (set! build-protect? #f) + (set! build-protect? #f) (send build-macro-km break-sequence)) #t)] [delete-key diff --git a/collects/framework/private/racket.rkt b/collects/framework/private/racket.rkt index 92f1af66..12bc1388 100644 --- a/collects/framework/private/racket.rkt +++ b/collects/framework/private/racket.rkt @@ -538,7 +538,7 @@ #f)] [last-para (and last (position-paragraph last))]) - (letrec + (letrec ([find-offset (λ (start-pos) (define tab-char? #f) diff --git a/collects/framework/test.rkt b/collects/framework/test.rkt index 1f64b784..855cac02 100644 --- a/collects/framework/test.rkt +++ b/collects/framework/test.rkt @@ -321,7 +321,7 @@ [else (update-control ctrl) (send ctrl command event) - (void)])))))) + (void)])))))) ;; ;; BUTTON diff --git a/collects/mred/private/moredialogs.rkt b/collects/mred/private/moredialogs.rkt index bec55f36..d3bc8c06 100644 --- a/collects/mred/private/moredialogs.rkt +++ b/collects/mred/private/moredialogs.rkt @@ -329,7 +329,7 @@ (send blue get-value)))] [install-color (lambda (color) - (send red set-value (send color red)) + (send red set-value (send color red)) (send green set-value (send color green)) (send blue set-value (send color blue)) (send canvas refresh))]) diff --git a/collects/mred/private/mrcanvas.rkt b/collects/mred/private/mrcanvas.rkt index 627f831d..462e654c 100644 --- a/collects/mred/private/mrcanvas.rkt +++ b/collects/mred/private/mrcanvas.rkt @@ -19,9 +19,10 @@ (define canvas-default-size 20) ; a default size for canvases tht fits borders without losing client sizes (define canvas-scroll-size 10) -(define canvas-control-border-extra (case (system-type) - [(windows) 2] - [else 0])) +(define canvas-control-border-extra + (case (system-type) + [(windows) 2] + [else 0])) (define canvas<%> (interface (subwindow<%>) diff --git a/collects/mred/private/wx/gtk/types.rkt b/collects/mred/private/wx/gtk/types.rkt index 59aea507..15841e07 100644 --- a/collects/mred/private/wx/gtk/types.rkt +++ b/collects/mred/private/wx/gtk/types.rkt @@ -8,8 +8,8 @@ _GdkScreen _gpointer _GType - _GdkEventType - _GdkAtom + _GdkEventType + _GdkAtom _fnpointer _gboolean @@ -31,9 +31,9 @@ (struct-out GdkEventExpose) _GdkEventFocus _GdkEventFocus-pointer (struct-out GdkEventFocus) - _GdkEventSelection _GdkEventSelection-pointer + _GdkEventSelection _GdkEventSelection-pointer (struct-out GdkEventSelection) - _GdkRectangle _GdkRectangle-pointer + _GdkRectangle _GdkRectangle-pointer (struct-out GdkRectangle) _GdkColor _GdkColor-pointer (struct-out GdkColor))) @@ -135,11 +135,11 @@ (define-cstruct _GdkEventSelection ([type _GdkEventType] [window _GdkWindow] [send_event _byte] - [selection _GdkAtom] - [target _GdkAtom] - [property _GdkAtom] - [time _uint32] - [requestor _pointer])) + [selection _GdkAtom] + [target _GdkAtom] + [property _GdkAtom] + [time _uint32] + [requestor _pointer])) (define-cstruct _GdkRectangle ([x _int] [y _int] @@ -155,8 +155,8 @@ (define-cstruct _GdkEventFocus ([type _GdkEventType] [window _GdkWindow] - [send_event _byte] - [in _short])) + [send_event _byte] + [in _short])) (define-cstruct _GdkColor ([pixel _uint32] [red _uint16] diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index 216d5461..8ee99033 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -1,7 +1,7 @@ #lang racket/base (require ffi/unsafe racket/class - net/uri-codec + net/uri-codec ffi/unsafe/atomic "../../syntax.rkt" "../../lock.rkt" @@ -18,7 +18,7 @@ "const.rkt" "types.rkt" "widget.rkt" - "clipboard.rkt") + "clipboard.rkt") (provide (protect-out window% @@ -35,7 +35,7 @@ connect-focus connect-key-and-mouse - connect-enter-and-leave + connect-enter-and-leave do-button-event (struct-out GtkRequisition) _GtkRequisition-pointer @@ -54,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) @@ -92,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))) @@ -123,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)))))])))))) ;; ---------------------------------------- @@ -147,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) @@ -195,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) @@ -317,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? @@ -345,7 +345,7 @@ [(1) 'left-up] [(3) 'right-up] [else 'middle-up])])] - [m (let-values ([(x y) (send wx + [m (let-values ([(x y) (send wx adjust-event-position (->long ((if motion? GdkEventMotion-x @@ -378,24 +378,24 @@ (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))))))))) + (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))))))))) ;; ---------------------------------------- @@ -592,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))) @@ -761,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 @@ -769,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 @@ -791,5 +791,5 @@ (lambda (win-box) (let ([win (mcar win-box)]) (when win - (gdk_window_thaw_updates win) + (gdk_window_thaw_updates win) (set-mcdr! win-box (sub1 (mcdr win-box))))))))) diff --git a/collects/mred/private/wx/win32/types.rkt b/collects/mred/private/wx/win32/types.rkt index d446fedc..6fbfee97 100644 --- a/collects/mred/private/wx/win32/types.rkt +++ b/collects/mred/private/wx/win32/types.rkt @@ -1,13 +1,13 @@ #lang racket/base (require ffi/unsafe - ffi/winapi) + ffi/winapi) (provide (protect-out _wfun - _WORD - _DWORD - _UDWORD + _WORD + _DWORD + _UDWORD _ATOM _WPARAM _LPARAM @@ -95,35 +95,35 @@ (define _permanent-string/utf-16 (make-ctype _pointer - (lambda (s) - (and s - (let ([v (malloc _gcpointer)]) - (ptr-set! v _string/utf-16 s) - (let ([p (ptr-ref v _gcpointer)]) - (let ([len (+ 1 (utf-16-length s))]) - (let ([c (malloc len _uint16 'raw)]) - (memcpy c p len _uint16) - c)))))) - (lambda (p) p))) + (lambda (s) + (and s + (let ([v (malloc _gcpointer)]) + (ptr-set! v _string/utf-16 s) + (let ([p (ptr-ref v _gcpointer)]) + (let ([len (+ 1 (utf-16-length s))]) + (let ([c (malloc len _uint16 'raw)]) + (memcpy c p len _uint16) + c)))))) + (lambda (p) p))) (define _LONG _long) (define _ULONG _ulong) (define _SHORT _short) (define-cstruct _POINT ([x _LONG] - [y _LONG])) + [y _LONG])) (define-cstruct _RECT ([left _LONG] - [top _LONG] - [right _LONG] - [bottom _LONG])) + [top _LONG] + [right _LONG] + [bottom _LONG])) (define-cstruct _MSG ([hwnd _HWND] - [message _UINT] - [wParam _WPARAM] - [lParam _LPARAM] - [time _DWORD] - [pt _POINT])) + [message _UINT] + [wParam _WPARAM] + [lParam _LPARAM] + [time _DWORD] + [pt _POINT])) (define (short v) (if (zero? (bitwise-and #x8000 v)) diff --git a/collects/mrlib/scribblings/switchable-button.scrbl b/collects/mrlib/scribblings/switchable-button.scrbl index df25e4cb..74d040a2 100644 --- a/collects/mrlib/scribblings/switchable-button.scrbl +++ b/collects/mrlib/scribblings/switchable-button.scrbl @@ -15,7 +15,7 @@ @defconstructor/auto-super[([label string?] [callback (-> (is-a?/c switchable-button%) any/c)] [bitmap (is-a?/c bitmap%)] - [alternate-bitmap (is-a?/c bitmap%) bitmap] + [alternate-bitmap (is-a?/c bitmap%) bitmap] [vertical-tight? boolean? #f])]{ The @racket[callback] is called when the button is pressed. The @racket[string] and @racket[bitmap] are diff --git a/collects/scribblings/framework/splash.scrbl b/collects/scribblings/framework/splash.scrbl index fc61340e..3de13845 100644 --- a/collects/scribblings/framework/splash.scrbl +++ b/collects/scribblings/framework/splash.scrbl @@ -26,7 +26,7 @@ that number to control the gauge along the bottom of the splash screen. [splash-title string?] [width-default exact-nonnegative-integer?] [#:allow-funny? allow-funny? boolean? #f] - [#:frame-icon + [#:frame-icon frame-icon (or/c #f (is-a?/c bitmap%) diff --git a/collects/tests/gracket/mem.rkt b/collects/tests/gracket/mem.rkt index 296104d9..ba7d3407 100644 --- a/collects/tests/gracket/mem.rkt +++ b/collects/tests/gracket/mem.rkt @@ -21,8 +21,8 @@ (define allocated '()) (define (remember tag v) (set! allocated - (cons (cons tag (make-weak-box v)) - allocated)) + (cons (cons tag (make-weak-box v)) + allocated)) v) (define sub-collect-frame @@ -71,163 +71,163 @@ (unless (zero? n) (let ([tag (cons id n)]) (let* ([edit (remember tag (make-object text%))] - [ef (let ([f (make-object frame% "Editor Frame")]) - (send (make-object editor-canvas% f) set-editor edit) - (remember tag f))] - [c (make-custodian)] - [es (parameterize ([current-custodian c]) - (make-eventspace))]) + [ef (let ([f (make-object frame% "Editor Frame")]) + (send (make-object editor-canvas% f) set-editor edit) + (remember tag f))] + [c (make-custodian)] + [es (parameterize ([current-custodian c]) + (make-eventspace))]) - (when edit? - (send ef show #t) - (sleep 0.1)) + (when edit? + (send ef show #t) + (sleep 0.1)) - (parameterize ([current-eventspace es]) - (send (remember - tag - (make-object - (class timer% + (parameterize ([current-eventspace es]) + (send (remember + tag + (make-object + (class timer% (init-rest args) - (override* [notify (lambda () (void))]) + (override* [notify (lambda () (void))]) (apply super-make-object args)))) - start 100)) + start 100)) - (when frame? - (let* ([f (remember tag - (make-object (if (even? n) - frame% - dialog%) - "Tester" #f 200 200))] - [cb (lambda (x y) f)] - [p (remember tag (make-object (get-pane% n) f))]) - (remember tag (make-object canvas% f)) - (when (zero? (modulo n 3)) - (thread (lambda () (send f show #t))) - (let loop () (sleep) (unless (send f is-shown?) (loop)))) - (remember tag (make-object button% "one" p cb)) - (let ([class check-box%]) - (let loop ([m 10]) - (unless (zero? m) - (remember (cons tag m) - (make-object class "another" p cb)) - (loop (sub1 m))))) - (remember tag (make-object check-box% "check" p cb)) - (remember tag (make-object choice% "choice" '("a" "b" "c") p cb)) - (remember tag (make-object list-box% "list" '("apple" "banana" "coconut") - p cb)) - (remember tag (make-object button% "two" p cb)) - (send f show #f))) + (when frame? + (let* ([f (remember tag + (make-object (if (even? n) + frame% + dialog%) + "Tester" #f 200 200))] + [cb (lambda (x y) f)] + [p (remember tag (make-object (get-pane% n) f))]) + (remember tag (make-object canvas% f)) + (when (zero? (modulo n 3)) + (thread (lambda () (send f show #t))) + (let loop () (sleep) (unless (send f is-shown?) (loop)))) + (remember tag (make-object button% "one" p cb)) + (let ([class check-box%]) + (let loop ([m 10]) + (unless (zero? m) + (remember (cons tag m) + (make-object class "another" p cb)) + (loop (sub1 m))))) + (remember tag (make-object check-box% "check" p cb)) + (remember tag (make-object choice% "choice" '("a" "b" "c") p cb)) + (remember tag (make-object list-box% "list" '("apple" "banana" "coconut") + p cb)) + (remember tag (make-object button% "two" p cb)) + (send f show #f))) - (when subwindows? - (let ([p (make-object (get-panel% n) sub-collect-frame)] - [cv (make-object canvas% sub-collect-frame)] - [add-objects - (lambda (p tag hide?) - (let ([b (let* ([x #f] - [bcb (lambda (a b) x)]) - (set! x (make-object button% "one" p bcb)) - x)] - [c (make-object check-box% "check" p void)] - [co (make-object choice% "choice" '("a" "b" "c") p void)] - [cv (make-object canvas% p)] - [lb (make-object list-box% "list" '("apple" "banana" "coconut") p void)]) - (when hide? - (send p delete-child b) - (send p delete-child c) - (send p delete-child cv) - (send p delete-child co) - (send p delete-child lb)) - (remember tag b) - (remember tag c) - (remember tag cv) - (remember tag co) - (remember tag lb)))]) - (add-objects sub-collect-panel (cons 'sc1 tag) #t) - (add-objects p (cons 'sc2 tag) #f) - (remember (cons 'sc0 tag) p) - (remember (cons 'sc0 tag) cv) - (send sub-collect-frame delete-child p) - (send sub-collect-frame delete-child cv))) + (when subwindows? + (let ([p (make-object (get-panel% n) sub-collect-frame)] + [cv (make-object canvas% sub-collect-frame)] + [add-objects + (lambda (p tag hide?) + (let ([b (let* ([x #f] + [bcb (lambda (a b) x)]) + (set! x (make-object button% "one" p bcb)) + x)] + [c (make-object check-box% "check" p void)] + [co (make-object choice% "choice" '("a" "b" "c") p void)] + [cv (make-object canvas% p)] + [lb (make-object list-box% "list" '("apple" "banana" "coconut") p void)]) + (when hide? + (send p delete-child b) + (send p delete-child c) + (send p delete-child cv) + (send p delete-child co) + (send p delete-child lb)) + (remember tag b) + (remember tag c) + (remember tag cv) + (remember tag co) + (remember tag lb)))]) + (add-objects sub-collect-panel (cons 'sc1 tag) #t) + (add-objects p (cons 'sc2 tag) #f) + (remember (cons 'sc0 tag) p) + (remember (cons 'sc0 tag) cv) + (send sub-collect-frame delete-child p) + (send sub-collect-frame delete-child cv))) - (when (and edit? insert?) - (let ([e edit]) + (when (and edit? insert?) + (let ([e edit]) (send e begin-edit-sequence) - (when load-file? - (send e load-file (build-path source-dir "mem.rkt"))) - (let loop ([i 20]) - (send e insert (number->string i)) - (unless (zero? i) - (loop (sub1 i)))) - (let ([s (make-object editor-snip%)]) - (send (send s get-editor) insert "Hello!") - (send e insert s)) - (send e insert #\newline) - (send e insert "done") - (send e set-modified #f) + (when load-file? + (send e load-file (build-path source-dir "mem.rkt"))) + (let loop ([i 20]) + (send e insert (number->string i)) + (unless (zero? i) + (loop (sub1 i)))) + (let ([s (make-object editor-snip%)]) + (send (send s get-editor) insert "Hello!") + (send e insert s)) + (send e insert #\newline) + (send e insert "done") + (send e set-modified #f) (send e end-edit-sequence))) - - (when menus? - (let ([f (remember tag (make-object frame% "MB Frame 0"))]) - (remember tag (make-object menu% "TM1" (remember (cons 'q tag) (make-object menu-bar% f))))) - (let* ([mb (remember tag (make-object menu-bar% ef))] - [m (remember tag (make-object menu% "Ok" mb))]) - (remember tag (make-object menu-item% "Hi" m void)) - (remember tag (make-object menu-item% "There" m void #\t)) - (remember tag - (make-object checkable-menu-item% - "Checkable" - (remember tag (make-object menu% "Hello" m)) - void)) - (let ([i (remember tag (make-object menu-item% "Delete Me" m void))]) - (send i delete))) + + (when menus? + (let ([f (remember tag (make-object frame% "MB Frame 0"))]) + (remember tag (make-object menu% "TM1" (remember (cons 'q tag) (make-object menu-bar% f))))) + (let* ([mb (remember tag (make-object menu-bar% ef))] + [m (remember tag (make-object menu% "Ok" mb))]) + (remember tag (make-object menu-item% "Hi" m void)) + (remember tag (make-object menu-item% "There" m void #\t)) + (remember tag + (make-object checkable-menu-item% + "Checkable" + (remember tag (make-object menu% "Hello" m)) + void)) + (let ([i (remember tag (make-object menu-item% "Delete Me" m void))]) + (send i delete))) - (when subwindows? - (unless permanent-ready? - (semaphore-wait mb-lock) - (unless (send sub-collect-frame get-menu-bar) - (let ([mb (make-object menu-bar% sub-collect-frame)]) - (make-object menu% "Permanent" mb))) - (set! permanent-ready? #t) - (semaphore-post mb-lock)) - (let* ([mb (send sub-collect-frame get-menu-bar)] - [mm (car (send mb get-items))]) - (send (remember (cons 'm tag) (make-object menu-item% "Delete Me" mm void)) delete) - (let ([m (remember tag (make-object menu% "Temporary" mb))]) - (remember (cons 't tag) (make-object menu-item% "Temp Hi" m void)) - (send m delete))))) - - (when atomic? - (let loop ([m 8]) - (unless (zero? m) - (remember (cons tag m) (make-object point% n m)) - (let ([br (make-object brush%)]) - (remember (cons tag m) br) - (hash-set! htw br 'ok)) - (remember (cons tag m) (make-object pen%)) - (loop (sub1 m))))) - - (when offscreen? - (let ([m (remember tag (make-object bitmap-dc%))] - [b0 (remember (cons tag 'f) (make-object bitmap% (get-image n)))] - [b (remember (cons tag 'u) (make-object bitmap% 100 100))] - [b2 (remember (cons tag 'x) (make-object bitmap% 100 100))]) - (unless (send b0 ok?) - (error "bitmap load error")) - (send m set-bitmap b))) - - (when edit? - (send ef show #f)) - - (custodian-shutdown-all c) + (when subwindows? + (unless permanent-ready? + (semaphore-wait mb-lock) + (unless (send sub-collect-frame get-menu-bar) + (let ([mb (make-object menu-bar% sub-collect-frame)]) + (make-object menu% "Permanent" mb))) + (set! permanent-ready? #t) + (semaphore-post mb-lock)) + (let* ([mb (send sub-collect-frame get-menu-bar)] + [mm (car (send mb get-items))]) + (send (remember (cons 'm tag) (make-object menu-item% "Delete Me" mm void)) delete) + (let ([m (remember tag (make-object menu% "Temporary" mb))]) + (remember (cons 't tag) (make-object menu-item% "Temp Hi" m void)) + (send m delete))))) - (collect-garbage) + (when atomic? + (let loop ([m 8]) + (unless (zero? m) + (remember (cons tag m) (make-object point% n m)) + (let ([br (make-object brush%)]) + (remember (cons tag m) br) + (hash-set! htw br 'ok)) + (remember (cons tag m) (make-object pen%)) + (loop (sub1 m))))) + + (when offscreen? + (let ([m (remember tag (make-object bitmap-dc%))] + [b0 (remember (cons tag 'f) (make-object bitmap% (get-image n)))] + [b (remember (cons tag 'u) (make-object bitmap% 100 100))] + [b2 (remember (cons tag 'x) (make-object bitmap% 100 100))]) + (unless (send b0 ok?) + (error "bitmap load error")) + (send m set-bitmap b))) + + (when edit? + (send ef show #f)) + + (custodian-shutdown-all c) - (maker id (sub1 n)))))) + (collect-garbage) + + (maker id (sub1 n)))))) (define (still) (map (lambda (x) - (let ([v (weak-box-value (cdr x))]) - (when v + (let ([v (weak-box-value (cdr x))]) + (when v (printf "~s ~s\n" (car x) v)))) allocated) (void)) @@ -241,29 +241,29 @@ (define (breakable t) (if #f (thread (lambda () - (read) - (printf "breaking\n") - (break-thread t) - (thread-wait t) - (printf "done\n"))) + (read) + (printf "breaking\n") + (break-thread t) + (thread-wait t) + (printf "done\n"))) (void))) (define (do-test) (let ([sema (make-semaphore)]) (let loop ([n num-threads]) (unless (zero? n) - (breakable - (thread (lambda () - (stw (current-thread) n) - (dynamic-wind - void - (lambda () (maker n num-times)) - (lambda () (semaphore-post sema)))))) - (loop (sub1 n)))) + (breakable + (thread (lambda () + (stw (current-thread) n) + (dynamic-wind + void + (lambda () (maker n num-times)) + (lambda () (semaphore-post sema)))))) + (loop (sub1 n)))) (let loop ([n num-threads]) (unless (zero? n) - (yield sema) - (loop (sub1 n))))) + (yield sema) + (loop (sub1 n))))) (collect-garbage) (collect-garbage) @@ -280,4 +280,3 @@ (still))) (do-test) - From 60d67d2552ea8dc76c2d3a448af11d1c4333964d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 7 Nov 2012 14:23:09 -0700 Subject: [PATCH 29/32] racket/gui: add `get-current-mouse-state' original commit: 7b04571facdafe778bfb05f9c54d7da6d467b05d --- collects/mred/mred-sig.rkt | 1 + collects/mred/private/mred.rkt | 1 + collects/mred/private/wx/cocoa/platform.rkt | 1 + collects/mred/private/wx/cocoa/procs.rkt | 31 ++++++++++++++++++-- collects/mred/private/wx/gtk/frame.rkt | 31 +++++++++++++++++++- collects/mred/private/wx/gtk/platform.rkt | 1 + collects/mred/private/wx/platform.rkt | 1 + collects/mred/private/wx/win32/platform.rkt | 1 + collects/mred/private/wx/win32/procs.rkt | 24 +++++++++++++++ collects/scribblings/gui/miscwin-funcs.scrbl | 9 ++++++ collects/tests/gracket/item.rkt | 26 ++++++++++++++++ 11 files changed, 124 insertions(+), 3 deletions(-) diff --git a/collects/mred/mred-sig.rkt b/collects/mred/mred-sig.rkt index bc49ba6e..8d7ecd83 100644 --- a/collects/mred/mred-sig.rkt +++ b/collects/mred/mred-sig.rkt @@ -78,6 +78,7 @@ frame% gauge% get-choices-from-user get-color-from-user +get-current-mouse-state get-default-shortcut-prefix get-directory get-display-count diff --git a/collects/mred/private/mred.rkt b/collects/mred/private/mred.rkt index 6e26e1b2..8f49d9fc 100644 --- a/collects/mred/private/mred.rkt +++ b/collects/mred/private/mred.rkt @@ -116,6 +116,7 @@ event-dispatch-handler eventspace? flush-display + get-current-mouse-state get-highlight-background-color get-highlight-text-color get-the-editor-data-class-list diff --git a/collects/mred/private/wx/cocoa/platform.rkt b/collects/mred/private/wx/cocoa/platform.rkt index 6ec950eb..1567a0c7 100644 --- a/collects/mred/private/wx/cocoa/platform.rkt +++ b/collects/mred/private/wx/cocoa/platform.rkt @@ -63,6 +63,7 @@ display-origin display-count flush-display + get-current-mouse-state fill-private-color cancel-quit get-control-font-face diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index 1d1400d1..63a656ec 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -6,6 +6,7 @@ ffi/unsafe ffi/unsafe/objc "utils.rkt" + "const.rkt" "types.rkt" "frame.rkt" "window.rkt" @@ -63,9 +64,10 @@ file-creator-and-type file-selector key-symbol-to-menu-key - needs-grow-box-spacer?) + needs-grow-box-spacer? + get-current-mouse-state) -(import-class NSScreen NSCursor NSMenu) +(import-class NSScreen NSCursor NSMenu NSEvent) (define (find-graphical-system-path what) #f) @@ -192,3 +194,28 @@ (define (needs-grow-box-spacer?) (not (version-10.7-or-later?))) + +;; ------------------------------------------------------------ +;; Mouse and modifier-key state + +(define (get-current-mouse-state) + (define posn (tell #:type _NSPoint NSEvent mouseLocation)) + (define buttons (tell #:type _NSUInteger NSEvent pressedMouseButtons)) + (define mods (tell #:type _NSUInteger NSEvent modifierFlags)) + (define (maybe v mask sym) + (if (zero? (bitwise-and v mask)) + null + (list sym))) + (define h (let ([f (tell #:type _NSRect (tell NSScreen mainScreen) frame)]) + (NSSize-height (NSRect-size f)))) + (values (make-object point% + (->long (NSPoint-x posn)) + (->long (- (- h (NSPoint-y posn)) (get-menu-bar-height)))) + (append + (maybe buttons #x1 'left) + (maybe buttons #x2 'right) + (maybe mods NSShiftKeyMask 'shift) + (maybe mods NSCommandKeyMask 'meta) + (maybe mods NSAlternateKeyMask 'alt) + (maybe mods NSControlKeyMask 'control) + (maybe mods NSAlphaShiftKeyMask 'caps)))) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index d46279c9..59fa9963 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -22,7 +22,8 @@ display-origin display-size display-count - location->window)) + location->window + get-current-mouse-state)) ;; ---------------------------------------- @@ -57,6 +58,13 @@ (define-gtk gtk_window_resize (_fun _GtkWidget _int _int -> _void)) (define-gdk gdk_window_set_cursor (_fun _GdkWindow _pointer -> _void)) +(define-gdk gdk_screen_get_root_window (_fun _GdkScreen -> _GdkWindow)) +(define-gdk gdk_window_get_pointer (_fun _GdkWindow + (x : (_ptr o _int)) + (y : (_ptr o _int)) + (mods : (_ptr o _uint)) + -> _GdkWindow + -> (values x y mods))) (define-gtk gtk_window_iconify (_fun _GtkWindow -> _void)) (define-gtk gtk_window_deiconify (_fun _GtkWindow -> _void)) @@ -543,3 +551,24 @@ [fh (send f get-height)]) (<= fy y (+ fy fh))) f)))) + +;; ---------------------------------------- + +(define (get-current-mouse-state) + (define-values (x y mods) (gdk_window_get_pointer + (gdk_screen_get_root_window + (gdk_screen_get_default)))) + (define (maybe mask sym) + (if (zero? (bitwise-and mods mask)) + null + (list sym))) + (values (make-object point% x y) + (append + (maybe GDK_BUTTON1_MASK 'left) + (maybe GDK_BUTTON2_MASK 'middle) + (maybe GDK_BUTTON3_MASK 'right) + (maybe GDK_SHIFT_MASK 'shift) + (maybe GDK_LOCK_MASK 'caps) + (maybe GDK_CONTROL_MASK 'control) + (maybe GDK_MOD1_MASK 'alt) + (maybe GDK_META_MASK 'meta)))) diff --git a/collects/mred/private/wx/gtk/platform.rkt b/collects/mred/private/wx/gtk/platform.rkt index a54adf28..1194feef 100644 --- a/collects/mred/private/wx/gtk/platform.rkt +++ b/collects/mred/private/wx/gtk/platform.rkt @@ -64,6 +64,7 @@ display-origin display-count flush-display + get-current-mouse-state fill-private-color cancel-quit get-control-font-face diff --git a/collects/mred/private/wx/platform.rkt b/collects/mred/private/wx/platform.rkt index 352f6366..5c2e0654 100644 --- a/collects/mred/private/wx/platform.rkt +++ b/collects/mred/private/wx/platform.rkt @@ -50,6 +50,7 @@ display-origin display-count flush-display + get-current-mouse-state fill-private-color cancel-quit get-control-font-face diff --git a/collects/mred/private/wx/win32/platform.rkt b/collects/mred/private/wx/win32/platform.rkt index 0a70c3d3..e3d775ef 100644 --- a/collects/mred/private/wx/win32/platform.rkt +++ b/collects/mred/private/wx/win32/platform.rkt @@ -64,6 +64,7 @@ display-origin display-count flush-display + get-current-mouse-state fill-private-color cancel-quit get-control-font-face diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 7c7f6d87..81ef379e 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -43,6 +43,7 @@ get-highlight-text-color check-for-break) flush-display + get-current-mouse-state fill-private-color play-sound location->window @@ -116,3 +117,26 @@ (define (check-for-break) #f) (define (needs-grow-box-spacer?) #f) + +(define-user32 GetCursorPos (_wfun (p : (_ptr o _POINT)) -> (r : _BOOL) + -> (if r + p + (failed 'GetCursorPos)))) +(define-user32 GetAsyncKeyState (_wfun _int -> _SHORT)) +(define-user32 GetSystemMetrics (_wfun _int -> _int)) +(define SM_SWAPBUTTON 23) +(define (get-current-mouse-state) + (define p (GetCursorPos)) + (define (maybe vk sym) + (if (negative? (GetAsyncKeyState vk)) + (list sym) + null)) + (define swapped? (not (zero? (GetSystemMetrics SM_SWAPBUTTON)))) + (values (make-object point% (POINT-x p) (POINT-y p)) + (append + (maybe (if swapped? VK_RBUTTON VK_LBUTTON) 'left) + (maybe (if swapped? VK_LBUTTON VK_RBUTTON) 'right) + (maybe VK_LSHIFT 'shift) + (maybe VK_CONTROL 'control) + (maybe VK_MENU 'alt) + (maybe VK_CAPITAL 'caps)))) diff --git a/collects/scribblings/gui/miscwin-funcs.scrbl b/collects/scribblings/gui/miscwin-funcs.scrbl index 441b46b5..a777274f 100644 --- a/collects/scribblings/gui/miscwin-funcs.scrbl +++ b/collects/scribblings/gui/miscwin-funcs.scrbl @@ -194,6 +194,15 @@ break is sent (via @racket[break-thread]) to the created eventspace's @tech{handler thread}.} +@defproc[(get-current-mouse-state) (values (is-a?/c point%) + (listof (or/c 'left 'middle 'right + 'shift 'control 'alt 'meta 'caps)))]{ + +Returns the current location of the mouse in screen coordinates, +and returns a list of symbols for mouse buttons and modifier keys +that are currently pressed.} + + @defproc[(hide-cursor-until-moved) void?]{ Hides the cursor until the user moves the mouse or clicks the mouse diff --git a/collects/tests/gracket/item.rkt b/collects/tests/gracket/item.rkt index 8566a951..dbc19149 100644 --- a/collects/tests/gracket/item.rkt +++ b/collects/tests/gracket/item.rkt @@ -2289,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)))))) ;---------------------------------------------------------------------- @@ -2370,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) From bdbce793741e923e3d4de4b0d15f5edfc5466150 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 7 Nov 2012 16:06:43 -0600 Subject: [PATCH 30/32] make the log follower always available in DrRacket original commit: 741be85f07f6d9fc66f3fa7ea9f679a2d9ad2c2a --- collects/framework/private/follow-log.rkt | 151 ++++++++++++++++++++++ collects/framework/private/frame.rkt | 18 ++- 2 files changed, 165 insertions(+), 4 deletions(-) create mode 100644 collects/framework/private/follow-log.rkt diff --git a/collects/framework/private/follow-log.rkt b/collects/framework/private/follow-log.rkt new file mode 100644 index 00000000..e45f9354 --- /dev/null +++ b/collects/framework/private/follow-log.rkt @@ -0,0 +1,151 @@ +#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 done-chan (make-channel)) +(define start-chan (make-channel)) +(void + (thread + (λ () + (let loop () + (sync start-chan) + (let loop ([events '()]) + (sync + (handle-evt + lr + (λ (info) + (loop (cons info events)))) + (handle-evt + done-chan + (λ (resp-chan) + (channel-put resp-chan events))))) + (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"] [parent f] + [callback + (λ (_1 _2) + (sb-callback))])) +(define db (new button% [label "Stop && Dump"] [parent f] [enabled #f] + [callback + (λ (_1 _2) + (define resp (make-channel)) + (channel-put done-chan resp) + (show-results (channel-get resp)) + (send db enable #f) + (send sb enable #t))])) +(define (sb-callback) + (send sb enable #f) + (send db enable #t) + (channel-put start-chan #t)) +(send f show #t) + +(struct gui-event (start end name) #:prefab) + +(define (show-results evts) + (define gui-events (filter (λ (x) + (define i (vector-ref x 2)) + (and (gui-event? i) + (number? (gui-event-end i)))) + evts)) + (define interesting-gui-events + (take (sort gui-events > #:key (λ (x) + (define i (vector-ref x 2)) + (- (gui-event-end i) + (gui-event-start i)))) + top-n-events)) + + (define with-other-events + (for/list ([gui-evt (in-list interesting-gui-events)]) + (match (vector-ref gui-evt 2) + [(gui-event start end name) + (define in-the-middle + (append (map (λ (x) (list (list 'δ (- (get-start-time x) start)) x)) + (sort + (filter (λ (x) (and (not (gui-event? (vector-ref x 2))) + (<= start (get-start-time x) end))) + evts) + < + #:key get-start-time)) + (list (list (list 'δ (- end start)) 'end-of-gui-event)))) + (list* (- end start) + gui-evt + in-the-middle)]))) + + (define (has-a-gc-event? x) + (define in-the-middle (cddr x)) + (ormap (λ (x) + (and (vector? (list-ref x 1)) + (gc-info? (vector-ref (list-ref x 1) 2)))) + in-the-middle)) + + (pretty-print + (if drop-gc? + (filter (λ (x) (not (has-a-gc-event? x))) + with-other-events) + with-other-events))) + +(struct gc-info (major? pre-amount pre-admin-amount code-amount + post-amount post-admin-amount + start-process-time end-process-time + start-time end-time) + #:prefab) +(struct engine-info (msec name) #:prefab) + +(define (get-start-time x) + (cond + [(gc-info? (vector-ref x 2)) + (gc-info-start-time (vector-ref x 2))] + [(engine-info? (vector-ref x 2)) + (engine-info-msec (vector-ref x 2))] + [(regexp-match #rx"framework" (vector-ref x 1)) + (vector-ref x 2)] + [(timeline-info? (vector-ref x 2)) + (timeline-info-milliseconds (vector-ref x 2))] + [else + (unless (regexp-match #rx"^GC: 0:MST @" (vector-ref x 1)) + (eprintf "unk: ~s\n" x)) + 0])) + + +(module+ main + (when start-right-away? + (parameterize ([current-eventspace controller-frame-eventspace]) + (queue-callback sb-callback))) + (dynamic-require 'drracket #f)) + diff --git a/collects/framework/private/frame.rkt b/collects/framework/private/frame.rkt index 215dab07..1464406f 100644 --- a/collects/framework/private/frame.rkt +++ b/collects/framework/private/frame.rkt @@ -796,9 +796,14 @@ [ec (new position-canvas% [parent panel] [button-up - (λ () - (collect-garbage) - (update-memory-text))] + (λ (evt) + (cond + [(or (send evt get-alt-down) + (send evt get-control-down)) + (dynamic-require 'framework/private/follow-log #f)] + [else + (collect-garbage) + (update-memory-text)]))] [init-width "99.99 MB"])]) (set! memory-canvases (cons ec memory-canvases)) (update-memory-text) @@ -890,6 +895,7 @@ (inherit min-client-height min-client-width get-dc get-client-size refresh) (init init-width) (init-field [button-up #f]) + (init-field [char-typed void]) (define str "") (define/public (set-str _str) (set! str _str) @@ -913,7 +919,11 @@ (let-values ([(cw ch) (get-client-size)]) (when (and (<= (send evt get-x) cw) (<= (send evt get-y) ch)) - (button-up)))))) + (if (procedure-arity-includes? button-up 1) + (button-up evt) + (button-up))))))) + (define/override (on-char evt) + (char-typed evt)) (super-new (style '(transparent no-focus))) (let ([dc (get-dc)]) (let-values ([(_1 th _2 _3) (send dc get-text-extent str)]) From 5447be30b5fcfc8a7e1562e603c10d0bb767e6cd Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 7 Nov 2012 21:51:36 -0600 Subject: [PATCH 31/32] should have been removed in an earlier commit, but I wrote the wrong git commandline original commit: d20f9a88666dd981c1836593d5b932dc22b18914 --- collects/drracket/private/follow-log.rkt | 149 ----------------------- 1 file changed, 149 deletions(-) delete mode 100644 collects/drracket/private/follow-log.rkt diff --git a/collects/drracket/private/follow-log.rkt b/collects/drracket/private/follow-log.rkt deleted file mode 100644 index bc3f52ef..00000000 --- a/collects/drracket/private/follow-log.rkt +++ /dev/null @@ -1,149 +0,0 @@ -#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 done-chan (make-channel)) -(define start-chan (make-channel)) -(void - (thread - (λ () - (let loop () - (sync start-chan) - (let loop ([events '()]) - (sync - (handle-evt - lr - (λ (info) - (loop (cons info events)))) - (handle-evt - done-chan - (λ (resp-chan) - (channel-put resp-chan events))))) - (loop))))) - -(define controller-frame-eventspace (make-eventspace)) -(define f (parameterize ([current-eventspace controller-frame-eventspace]) - (new frame% [label ""]))) -(define sb (new button% [label "Start"] [parent f] - [callback - (λ (_1 _2) - (sb-callback))])) -(define db (new button% [label "Stop && Dump"] [parent f] [enabled #f] - [callback - (λ (_1 _2) - (define resp (make-channel)) - (channel-put done-chan resp) - (show-results (channel-get resp)) - (send db enable #f) - (send sb enable #t))])) -(define (sb-callback) - (send sb enable #f) - (send db enable #t) - (channel-put start-chan #t)) -(send f show #t) - -(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])) - - -(when start-right-away? - (parameterize ([current-eventspace controller-frame-eventspace]) - (queue-callback sb-callback))) -(dynamic-require 'drracket #f) From 8cef1728454d8dc2fcbfa49bda86fe593fe4ddb7 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 8 Nov 2012 07:43:59 -0600 Subject: [PATCH 32/32] add support for collecting backtraces original commit: 87dae0df7a3c874a57cc7dd903fc30b69b11a459 --- collects/framework/private/follow-log.rkt | 96 ++++++++++++++++++++--- 1 file changed, 85 insertions(+), 11 deletions(-) diff --git a/collects/framework/private/follow-log.rkt b/collects/framework/private/follow-log.rkt index e45f9354..fbf4f7a0 100644 --- a/collects/framework/private/follow-log.rkt +++ b/collects/framework/private/follow-log.rkt @@ -35,13 +35,15 @@ log message was reported. (define drop-gc? #t) (define start-right-away? #f) -(define done-chan (make-channel)) -(define start-chan (make-channel)) +(define log-done-chan (make-channel)) +(define bt-done-chan (make-channel)) + +(define start-log-chan (make-channel)) (void (thread (λ () (let loop () - (sync start-chan) + (sync start-log-chan) (let loop ([events '()]) (sync (handle-evt @@ -49,32 +51,104 @@ log message was reported. (λ (info) (loop (cons info events)))) (handle-evt - done-chan + 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"] [parent f] +(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) - (define resp (make-channel)) - (channel-put done-chan resp) - (show-results (channel-get resp)) - (send db enable #f) - (send sb enable #t))])) + (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-chan #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)